*COMDECK COM1
      COMMON/C1/Q(32,16,32)
      COMMON /C3/ ALP,RE,FSMACH,GAMMA,JMAX,KMAX,LMAX,JWMAX,LWF,ND,LE,FN
     1,NOPT,JT,ETAE,ITMAX,LMAXBC,L1BC,SMU,DT,PR,TW,KREADY,IRGRID,ICRUDE,
     2  ITOT,INWALL,LW,KW,JREADX,IWRIT,JLW,JKW,KLW,FSP,FST,JL1WL,JL1WU,
     3  KMAXBC,JK1WU,JK1WL
      COMMON/C4/IGEOM,XMAX,XZERO,YMAX,X1,X2,X3,X4,Z1,Z2,Z3,Z4,ZT,RT
      COMMON /C5/EMC(32),UC(32),PC(32),TC(32),UE(32),DELT(32),DELTZ(32)
      COMMON /C6/RI(32),PTI(32),HTI(32),VROUI(32),PTOT(32,32),
     1  HTOT(32,32),VOU(32,32),WOU(32,32),RL(32)
      COMMON/C7/YKR(32),TH(32),X(32)
      COMMON/C8/XX(32,3)
      COMMON/IO/NLROW,NKLP,NLSKIP
C     LEVEL 2,Q,X,Y,Z
*DECK CRUDIC
      SUBROUTINE CRUDIC
*CALL COM1
      DIMENSION QSAVE(32,5,32)
      EMC2(B)=1.+FLOAT(IJ)*B**.5
      FUNC(A)=4.*EMC2(A)*(1.+(GAMMA-1.)/2.*EMC2(A))
       IF(NOPT.EQ.3) GO TO 60
C
C     NOPT=2
C
      CALL LKPGAS(JMAX,2)
      XMAX=Q(1,6,1)
      LW1=LW+1
      KW1=KW+1
      DO 50 J=1,JMAX
      CALL LKPGAS(J,2)
      DO 42 K=1,KMAX
C
C   SET UP INITIAL CONDITIONS AT INFLOW PLANE J=1
C
      IF(J.GT.1) GO TO 20
C
C     INSIDE OF THE NOZZLE FOR NOPT =2 WE WILL USE INITQ RESULTS
C
C     OUTSIDE OF THE NOZZLE
C
C
      DO 10 L=LW1,LMAX
      PCTOT=(FSP/PTOT(L,K))**((GAMMA-1.)/GAMMA)
      VLS=2.*HTOT(L,K)*(1.-PCTOT)/(GAMMA-1.)
      VL=SQRT(VLS)
      Q(L,1,K)=PTOT(L,K)/HTOT(L,K)*(FSP/PTOT(L,K))**(1.0/GAMMA)
      Q(L,2,K)=Q(L,1,K)*VL/SQRT(1.+VOU(L,K)**2+WOU(L,K)**2)
      Q(L,3,K)=Q(L,2,K)*VOU(L,K)
      Q(L,4,K)=Q(L,2,K)*WOU(L,K)
      T=HTOT(L,K)*PCTOT
      Q(L,5,K)=Q(L,1,K)*(T/(GAMMA*(GAMMA-1.))+VLS/2.)
   10 CONTINUE
      DO 15 L=LW1,LMAX
      DO 15 N=1,5
      QSAVE(L,N,K)=Q(L,N,K)
   15 CONTINUE
   20 CONTINUE
C
C     SET UP INITIAL CONDITIONS IN PLANES J > 0
C
      IF (J.EQ.1) GO TO 40
C
C     OUTSIDE THE NOZZLE L > LW  (REGION 1 AND 2)
C
      DO 35 L=LW1,LMAX
      IF (L.EQ.LMAX) GO TO 30
      DO 25 N=1,5
   25 Q(L,N,K)=QSAVE(L,N,K)
      GO TO 35
C
C     FREESTREAM BOUNDARY L=LMAX
C
   30 Q(L,1,K)=FSP/FST
      Q(L,2,K)=Q(L,1,K)*(FSMACH*SQRT(FST))
      Q(L,3,K)=0.
      Q(L,4,K)=0.
      Q(L,5,K)=FSP*(1./(GAMMA*(GAMMA-1.))+.5*FSMACH**2)
   35 CONTINUE
   40 CONTINUE
C     BEYOND THE END OF THE NOZZLE AND INSIDE THE NOZZLE L=1,LW
C     REGION 3 AND 4
C    INSIDE NOZZLE FOR NOPT=2 WE WILL USE INITQ RESULTS
   42 CONTINUE
C     ENSURE VELOCITIES = 0 AT WALLS
      IF(LW.EQ.0) GO TO 46
      DO 45 L=LW,LW1
      DO 45 K=1,KMAX
      Q(L,2,K)=0.
      Q(L,3,K)=0.
      Q(L,4,K)=0.
      IF (L.EQ.LW) GO TO 45
      Q(L,1,K)=PTOT(L,K)/HTOT(L,K)
      Q(L,5,K)=PTOT(L,K)/(GAMMA*(GAMMA-1.))
   45 CONTINUE
   46 CONTINUE
      CALL LKPGAS(J,1)
   50 CONTINUE
      GO TO 999
   60 CONTINUE
C
C     NOPT=3
C
      JKLW=MIN0(JKW,JLW)
      IF(KW.EQ.0) KMW=KMAX
      IF(KW.NE.0) KMW=KW
      IF(LW.EQ.0) LMW=LMAX
      IF(LW.NE.0) LMW=LW
      CALL XYZXI(KMAX,JMAX,LMAX)
C
C  CALCULATE LOCAL STATIC PRESSURE
C
      T0=1.0
      P0=1.0
      DO 65 I=1,2
      IF(JT.EQ.JMAX.AND.I.EQ.1) GO TO 65
      IF(I.EQ.1) IJ=+1
      IF(I.EQ.2) IJ=-1
      J=JT
      CALL LKPGAS(J,2)
      PHIJ=0.
      XXX=Q(1,6,1)
      CALL GEOM(XXX,AJ,ZZT)
      EMC(J)=1.
   63 TC(J)=T0/(1.+(GAMMA-1.)/2.*EMC(J)**2)
      PC(J)=P0*TC(J)**(GAMMA/(GAMMA-1.))
      IF(J.EQ.JMAX) GO TO 65
      IF(J.EQ.1) GO TO 65
      J=J+IJ
      AB=AJ
      CALL LKPGAS(J,2)
      XXX=Q(1,6,1)
      CALL GEOM(XXX,AJ,ZZT)
      DELPSI=ALOG(AJ/AB)
      PHIHAT=PHIJ+DELPSI*FUNC(PHIJ)
      PHIJ=.5*(PHIJ+PHIHAT+DELPSI*FUNC(PHIHAT))
      EMC(J)=EMC2(PHIJ)**.5
      GO TO 63
   65 CONTINUE
      DO 100 J=1,JMAX
      CALL LKPGAS(J,2)
      DO 70 K=1,KMAX
      DO 70 L=1,LMAX
      P=FSP
      IF(K.LE.KW.AND.L.LE.LW.AND.J.LT.JKLW) P=PC(J)
      CALL QCALC(J,K,L,HTOT(L,K),PTOT(L,K),P)
   70 CONTINUE
C
C     ZERO VELOCITY AT ALL WALLS
C
      IF(J.LT.JKLW) GO TO 80
      IF(J.GT.JKW) GO TO 75
      DO 72 L=1,LW1
      DO 72 K=KW,KW1
      P=FSP
      CALL QZERO(J,K,L,HTOT(L,K),PTOT(L,K),P)
   72 CONTINUE
   75 IF(J.GT.JLW) GO TO 90
      DO 77 K=1,KW1
      DO 77 L=LW,LW1
      P=FSP
      CALL QZERO(J,K,L,HTOT(L,K),PTOT(L,K),P)
   77 CONTINUE
      GO TO 90
   80 IF(KW.EQ.0) GO TO 86
      DO 85 K=KW,KW1
      IF(K.EQ.KW) P=PC(J)
      IF(K.EQ.KW+1) P=FSP
      IF(K.EQ.KW) LS=LW
      IF(K.EQ.KW+1) LS=LW+1
      IF(LW.EQ.0) LS=LMAX
      DO 85 L=1,LS
      CALL QZERO(J,K,L,HTOT(L,K),PTOT(L,K),P)
   85 CONTINUE
   86 IF(LW.EQ.0) GO TO 90
      DO 87 L=LW,LW1
      IF(L.EQ.LW) P=PC(J)
      IF(L.EQ.LW+1) P=FSP
      IF(L.EQ.LW) KS=KW
      IF(L.EQ.LW+1) KS=KW+1
      IF(KW.EQ.0) KS=KMAX
      DO 87 K=1,KS
      CALL QZERO(J,K,L,HTOT(L,K),PTOT(L,K),P)
   87 CONTINUE
   90 IF(J.LT.JL1WL) GO TO 95
      IF(J.GT.JL1WU) GO TO 95
C
C   WEDGE PLUG AT L=1
C
      DO 92 K=1,KMW
      L=1
      IF(J.GE.JKLW) P=FSP
      IF(J.LT.JKLW) P=PC(J)
      CALL QZERO(J,K,L,HTOT(L,K),PTOT(L,K),P)
   92 CONTINUE
   95 CONTINUE
      IF(JK1WU.EQ.0) GO TO 99
      IF(J.LT.JK1WL) GO TO 99
      IF(J.GT.JK1WU) GO TO 99
C
C    WEDGE PLUG AT K=1
C
      DO 97 L=1,LMW
      K=1
      IF(J.LT.JKLW) P=PC(J)
      IF(J.GE.JKLW) P=FSP
      CALL QZERO(J,K,L,HTOT(L,K),PTOT(L,K),P)
   97 CONTINUE
   99 CALL LKPGAS(J,1)
C
  100 CONTINUE
  999 RETURN
      END
*DECK DELI
      FUNCTION DELI(X)
      DELI=.025*RWFUNC(X)
      RETURN
      END
*DECK DELOUT
      FUNCTION DELOUT(X)
      DELOUT=.01*(RMAX(X)-RWOUT(X))
      RETURN
      END
*DECK DKMET
      SUBROUTINE DKMET(J,K,L,XK,YK,ZK)
*CALL COM1
C     INTERMEDIATE WALL IN K DIRECTION
      IF(KPLANE.EQ.0) GO TO 100
      XK=0.0
      YK=1.0
      ZK=0.0
      RETURN
  100 DY2 = .5
      KP = K+1
      KR = K-1
      IF(KW.LE.0.OR.K.LT.KW.OR.K.GT.KW+1.OR.J.GT.JKW) GO TO 200
      IF(LW.GT.0.AND.L.GT.LW) GO TO 200
      IF(K.EQ.KW) GO TO 700
      IF(K.EQ.KW+1) GO TO 500
  200 IF(K.NE.1) GO TO 600
C     TEST FOR INTERMEDIATE WALL NORMAL TO K=1 SURFACE
      IF(LW) 300,300,450
  300 IF(JK1WL.LE.J.AND.J.LE.JK1WU) GO TO 500
C     SYMMETRY
  400 XK=0.0
      ZK=0.0
      YK=2.0*(Q(L,7,KP)-Q(L,7,K))*DY2
      RETURN
C     TEST FOR WALL NORMAL TO K=1 SURFACE
  450 IF(L-LW) 300,300,400
C     FORWARD DIFFERENCE
  500 FAC=2.0
      KR=K
      GO TO 900
  600 IF(K.NE.KMAX) GO TO 800
      IF(KMAXBC.LT.3.OR.KMAXBC.GT.4) GO TO 700
C     SYMMETRY
      XK=0.0
      YK=0.0
      ZK=0.0
      IF(KMAXBC.EQ.3) YK=2.0*(Q(L,7,K)-Q(L,7,KR))*DY2
      IF(KMAXBC.EQ.4) ZK=2.0*(Q(L,8,K)-Q(L,8,KR))*DY2
      RETURN
C     BACKWARD DIFFERENCE
  700 KP=K
      FAC=2.0
      GO TO 900
C     CENTRAL DIFFERENCE
  800 FAC=1.0
  900 XK=0.
      YK=(Q(L,7,KP)-Q(L,7,KR))*DY2*FAC
      ZK=(Q(L,8,KP)-Q(L,8,KR))*DY2*FAC
      RETURN
      END
*DECK DLMET
      SUBROUTINE DLMET(J,K,L,XL,YL,ZL)
*CALL COM1
C     INTERMEDIATE WALL IN L DIRECTION
      DZ2 = .5
      LP = L+1
      LR = L-1
      IF(LW.LE.0.OR.L.LT.LW.OR.L.GT.LW+1.OR.J.GT.JLW) GO TO 100
      IF(KW.GT.0.AND.K.GT.KW) GO TO 100
      IF(L.EQ.LW) GO TO 700
      IF(L.EQ.LW+1) GO TO 500
  100 IF(L.NE.1) GO TO 600
C     AXIS OF SYMMETRY
      IF(LAXIS.NE.1) GO TO 150
      XL=0.0
      YL=Q(LP,7,K)-Q(L,7,K)
      ZL=Q(LP,8,K)-Q(L,8,K)
      GO TO 999
C     TEST FOR INTERMEDIATE WALL NORMAL TO L=1 SURFACE
  150 IF(KW) 200,200,400
C     TEST FOR WALL AT L=1
  200 IF(JL1WL.LE.J.AND.J.LE.JL1WU) GO TO 500
C     SYMMETRY
  300 XL=0.0
      YL=0.0
      ZL=2.0*(Q(LP,8,K)-Q(L,8,K))*DZ2
      GO TO 999
C     TEST FOR WALL AT L=1
  400 IF(K-KW) 200,200,300
C     FORWARD DIFFERENCE
  500 LR=L
      FAC=2.0
      GO TO 900
  600 IF(L.NE.LMAX) GO TO 800
      IF(LMAXBC.LT.3.OR.LMAXBC.GT.4) GO TO 700
C     SYMMETRY
      XL=0.0
      YL=0.0
      ZL=0.0
      IF(LMAXBC.EQ.3) YL=2.0*(Q(L,7,K)-Q(LR,7,K))*DZ2
      IF(LMAXBC.EQ.4) ZL=2.0*(Q(L,8,K)-Q(LR,8,K))*DZ2
      GO TO 999
C     BACKWARD DIFFERENCE
  700 LP=L
      FAC=2.0
      GO TO 900
C     CENTRAL DIFFERENCE
  800 FAC=1.0
  900 XL=0.
      YL=(Q(LP,7,K)-Q(LR,7,K))*DZ2*FAC
      ZL=(Q(LP,8,K)-Q(LR,8,K))*DZ2*FAC
  999 RETURN
      END
*DECK GEOM
      SUBROUTINE GEOM(XIN,A,ZIN)
*CALL COM1
      DIMENSION AR(32),B(32)
      DATA PI2/1.57079632/
      DATA IFIRST/0/
      ZFUNC(XXX)=ZT+XXX*XXX/(RT+(RT*RT-XXX*XXX)**.5)
      IF (NOPT.EQ.2) GO TO 70
      IF (NOPT.EQ.3) GO TO 80
      IF (IGEOM.EQ.2) GO TO 25
C     2D COSINE NOZZLE
      XT=0.
      ZI=2.0
      ZE=1.5
      ZT=1.0
C     NOZZLE HEIGHT Z AND AREA A AT STATION X RELATIVE TO THROAT XT
      IF (XIN-XT) 10,10,15
   10 ZIN=ZT+.5*(ZI-ZT)*(1.+COS(PI2*(XIN-XZERO)))
      GO TO 20
   15 ZIN=ZT+.5*(ZE-ZT)*(1.+COS(PI2*(XMAX-XIN)))
C     2D NOZZLE AREA
   20 A=ZIN
      GO TO 95
   25 CONTINUE
      IF (IFIRST.NE.0) GO TO 30
      ZT=.5388
      RT=1.0777
      X1=-2.275
      X2=-.4095
      X3=.0228
      X4=2.275
      Z1=1.3859
      Z2=ZFUNC(X2)
      Z3=ZFUNC(X3)
      Z4=.5868
      IFIRST=1
   30 CONTINUE
      IF (XIN-X1) 35,35,40
   35 ZIN=Z1
      GO TO 65
   40 IF (XIN-X2) 45,45,50
   45 ZIN=Z1+((Z2-Z1)/(X2-X1))*(XIN-X1)
      GO TO 65
   50 IF (XIN-X3) 55,55,60
   55 ZIN=ZFUNC(XIN)
      GO TO 65
   60 ZIN=Z3+((Z4-Z3)/(X4-X3))*(XIN-X3)
   65 A=ZIN*YMAX
      GO TO 95
C
C   NOPT=2
C
   70 A=PI2/2.*RWFUNC(XIN)**2
      GO TO 95
C
C     NOPT=3
C
   80 KT=KMAX
      IF(KW.GT.0) KT=KW
      LT=LMAX
      IF(LW.GT.0) LT=LW
      DO 85 L=1,LT
      CALL XXM(L,J,1,KT)
      DO 83 K=1,KT
      DA=SQRT(XX(K,1)*XX(K,1)+XX(K,2)*XX(K,2)+XX(K,3)*XX(K,3))
   83 AR(K)=DA
      CALL QDRTR(B(L),AR,1.,1,KT)
   85 CONTINUE
      CALL QDRTR(A,B,1.,1,LT)
   95 RETURN
      END
*DECK INFLOW
      SUBROUTINE INFLOW
*CALL COM1
      ITOT=LMAX
      INWALL =LW
      XXX=X(1)/ZT
      RWI=RWFUNC(XXX)*ZT
      RWO=RWOUT(XXX)*ZT
      GAMI=GAMMA/(GAMMA-1.)
      DELI=.05
      DELO=1.0
      DO 35 L=1,LW
      RI(L)=RL(L)
      RR=(RWI-RI(L))/DELI
      IF(RR.GE.1) GO TO 20
      IF(RR.GT.3.E-3) GO TO 15
      UUE=145.3*RR
      GO TO 30
   15 UUE=RR**(1./7.)
      GO TO 30
   20 UUE=1.
   30 CONTINUE
      HTI(L)=1.
      VROUI(L)=0.
      PTI(L)=(1.+(GAMMA-1)/2.*EMC(1)**2*(1.-UUE*UUE))**(-GAMI)
      WRITE(6,100) L,RI(L),PTI(L),HTI(L),VROUI(L)
  100 FORMAT(22H L,RI,PTI,HTI,VROUI= ,I3,1P4E12.5)
   35 CONTINUE
      LW1=LW+1
      DO 70 L=LW1,LMAX
      RI(L)=RL(L)
      VROUI(L)=0.
      UUO=(RI(L)-RWO)/DELO
      IF(UUO.GT.1.) GO TO 50
      UUO=UUO**(1./7.)
      GO TO 60
   50 UUO=1.
   60 SAVE=(GAMMA-1.)/2.*FSMACH**2
      HTI(L)=FST*(1.+SAVE)
      PTI(L)=FSP*((1.+SAVE)/(1.+SAVE*(1-UUO*UUO)))**GAMI
      WRITE(6,100) L,RI(L),PTI(L),HTI(L),VROUI(L)
   70 CONTINUE
      RETURN
      END
*DECK INITQ
      SUBROUTINE INITQ
C     INITIALIZE FLOW VARIABLES Q(L,N,K) AT GRID POINTS
*CALL COM1
      DIMENSION ETA(13),FP(13),G(13)
      DIMENSION PT(32),HT(32),VROU(32),ZRL(32)
      DIMENSION TE(32)
      DATA ETA/0.0,0.5,1.0,1.5,2.0,2.5,3.0,3.5,4.0,4.5,5.0,5.5,6.0/
      DATA FP/0.0,.16586,.32979,.48652,.62977,.75073,.84605,.91255,
     1                               .95552,.97928,.99155,.99682,.99898/
      DATA G/0.0,.03978,.16422,.35812,.60951,.87940,1.14133,1.3557,
     1                          1.51632,1.61644,1.67446,1.70189,1.71424/
      EMC2(B)=1.+FLOAT(IJ)*B**.5
      FUNC(A)=4.*EMC2(A)*(1.+(GAMMA-1.)/2.*EMC2(A))
C     INITIAL DATA FOR FLAT PLATE BOUNDARY LAYER(NOPT=0)
      IF (NOPT.GT.0) GO TO 45
      DO 10 I=1,13
   10 ETA(I)=ETA(I)/6.0
      DO 40 J=1,JWMAX
      CALL LKPGAS(J,2)
      DO 35 L=LWF,LMAX
      ZETA=(L-1.0)/(LMAX-1.0)
      ZETAE=(LE-1.)/(LMAX-1.0)
      ZFAC=(FN+1.)*(FN**(ZETA/(1.-ZETAE))-1.)/(FN**(1./(1.-ZETAE))-1.)
      IF(ZFAC.EQ.0.) EZFAC=1.
      IF(ZFAC.EQ.0.) GO TO 12
      EZFAC=EXP(-(6.1*ZFAC)**2)
   12 G4=1.71424*FSMACH*EZFAC/2.0
      G5=1.0/(GAMMA*(GAMMA-1.0))
      DO 35 K=1,KMAX
      ETAJ=Q(L,8,K)*SQRT(RE/Q(L,6,K))/ETAE
      IF (ETAJ.GT.1.0) GO TO 30
      DO 15 I=1,13
      IF (ETA(I).GT.ETAJ) GO TO 20
   15 CONTINUE
      I=12
   20 IF(I.EQ.13) I=12
      IE=1
      CALL TRPOL8(ETAJ,ETA,FP,I-1,FPJ)
      CALL TRPOL8(ETAJ,ETA,G,I-1,GJ)
      U=FSMACH*FPJ
      V=0.0
      W=FSMACH*GJ/(2.0*SQRT(Q(L,6,K)*RE))
      Q(L,1,K)=1.0/(1.0+.5*(GAMMA-1.0)*FSMACH**2*(1.0-(U/FSMACH)**2))
      IF (TW.LE.0.0) GO TO 25
      TB=TW+(U/FSMACH)*(1.0-TW+(GAMMA-1.0)/2.0*FSMACH**2*(1.0-U/FSMACH))
      Q(L,1,K)=1.0/TB
   25 Q(L,2,K)=Q(L,1,K)*U
      Q(L,3,K)=Q(L,1,K)*V
      Q(L,4,K)=Q(L,1,K)*W
      Q(L,5,K)=G5+.5*(Q(L,2,K)**2+Q(L,3,K)**2+Q(L,4,K)**2)/
     1                                                        Q(L,1,K)
      GO TO 35
   30 Q(L,1,K)=1.0
      Q(L,2,K)=FSMACH
      Q(L,3,K)=0.0
      Q(L,4,K)=G4/SQRT(Q(L,6,K)*RE)
      IF(FSMACH.LE.1.)Q(L,4,K)=1.71424*FSMACH/(2.*SQRT(Q(L,6,K)*RE))
      Q(L,5,K)=G5+.5*(Q(L,2,K)**2+Q(L,3,K)**2+Q(L,4,K)**2)/
     1                                                        Q(L,1,K)
   35 CONTINUE
      CALL LKPGAS(J,1)
   40 CONTINUE
      GO TO 999
C     INITIAL DATA FOR INTERIOR OF 2D NOZZLE
   45 CONTINUE
      IF (NOPT.EQ.3) GO TO 85
      LE=(LMAX+1)/2
      IF(LW.GT.0) LE=(LW+1)/2
C     SET STAGNATION PRESSURE AND TEMPERATURE
      T0=1.0
      P0=1.0
      LMW=LMAX
      IF(LW.GT.0) LMW=LW
C     1-D ISENTROPIC CHOKED FLOW
      CALL XYZXI(KMAX,JMAX,LMW)
      DO 80 I=1,2
      IF (JT.EQ.JMAX.AND.I.EQ.1) GO TO 80
      IF(I.EQ.1) IJ=+1
      IF(I.EQ.2) IJ=-1
      J=JT
      CALL LKPGAS(J,2)
      PHIJ=0.
      XXX=Q(1,6,1)
      CALL GEOM(XXX,AJ,ZZT)
      EMC(J)=1.
C     AVERAGE FLOW VARIABLES
   50 TC(J)=T0/(1.+(GAMMA-1.)/2.*EMC(J)**2)
      PC(J)=P0*TC(J)**(GAMMA/(GAMMA-1.))
      UC(J)=EMC(J)*TC(J)**.5
      DO 75 L=1,LMW
      DO 75 K=1,KMAX
      IF (L.GT.LE) GO TO 55
      UL=UC(J)
      TL=TC(J)
      GO TO 65
   55 UL=UC(J)*FLOAT(LMW-L)/FLOAT(LMW-LE)
      IF (TW.GT.0) GO TO 60
      TL=TC(J)*(1.+(GAMMA-1.)/2.*EMC(J)**2*(1.-(UL/UC(J))**2))
      GO TO 65
   60 TL=TW+(UL/UC(J))*(-TW+TC(J)*(1.+(GAMMA-1.)/2.*EMC(J)**2*(1.-UL/
     1  UC(J))))
   65 VL=0.
      XJ=Q(L,13,K)
      YJ=Q(L,14,K)
      ZJ=Q(L,15,K)
      WL=UL*ZJ/XJ
      IF (NOPT.LT.2) GO TO 70
      IF(K.EQ.1) VR=UL*ZJ/XJ
      VL=VR*SIN(TH(K))
      WL=VR*COS(TH(K))
   70 CONTINUE
      RHOL=PC(J)/TL
      EL=PC(J)/(GAMMA*(GAMMA-1.))+RHOL*((UL*UL+VL*VL+WL*WL)/2.)
      Q(L,1,K)=RHOL
      Q(L,2,K)=RHOL*UL
      Q(L,3,K)=RHOL*VL
      Q(L,4,K)=RHOL*WL
      Q(L,5,K)=EL
   75 CONTINUE
      CALL LKPGAS(J,1)
      IF (J.EQ.JMAX) GO TO 80
      IF (J.EQ.1) GO TO 80
      J=J+IJ
      AB=AJ
      CALL LKPGAS(J,2)
      XXX=Q(1,6,1)
      CALL GEOM(XXX,AJ,ZZT)
      DELPSI=ALOG(AJ/AB)
      PHIHAT=PHIJ+DELPSI*FUNC(PHIJ)
      PHIJ=.5*(PHIJ+PHIHAT+DELPSI*FUNC(PHIHAT))
      EMC(J)=EMC2(PHIJ)**.5
      GO TO 50
   80 CONTINUE
      IF(NOPT.EQ.2.AND.ITOT.EQ.0.AND.IGEOM.EQ.0) CALL INFLOW
   85 CONTINUE
      IF (ITOT.EQ.0) GO TO 145
      CALL LKPGAS(1,2)
      DO 100 I=1,ITOT
      IF (LW.GT.0) GO TO 90
      RI(I)=RI(I)/RI(ITOT)
      GO TO 100
   90 IF (I.GT.INWALL) GO TO 95
      RI(I)=RI(I)/RI(INWALL)
      GO TO 100
   95 IF(I.EQ.INWALL+1) RISAVE=RI(INWALL+1)
      RI(I)=(RI(I)-RISAVE)/(RI(ITOT)-RISAVE)
  100 CONTINUE
      DO 120 L=1,LMAX
      LL=LMAX
      IF (LW.EQ.0) GO TO 110
      LL=LW
      IF (L.LE.LW) GO TO 110
      IF (NOPT.GT.1) GO TO 105
      ZRL(L)=(Q(L,8,1)-Q(LL+1,8,1))/(Q(LMAX,8,1)-Q(LL+1,8,1))
      GO TO 120
  105 ZRL(L)=(RL(L)-RL(LW+1))/(RL(LMAX)-RL(LW+1))
      GO TO 120
  110 IF (NOPT.GT.1) GO TO 115
      ZRL(L)=Q(L,8,1)/Q(LL,8,1)
      GO TO 120
  115 ZRL(L)=RL(L)/RL(LL)
  120 CONTINUE
C
C     INTERPOLATE RADIAL DISTRIBUTION OF PRESSURE AND TOTAL ENTHALPY
C     TO ACTUAL GRID
C
      DO 135 L=1,LMAX
      IF(L.GT.LW) GO TO 131
      DO 130 I=1,INWALL
      C1=ZRL(L)-RI(I)
      C2=RI(I+1)-ZRL(L)
      IF (C1*C2) 130,125,125
  125 PT(L)=(C1*PTI(I+1)+C2*PTI(I))/(C1+C2)
      HT(L)=(C1*HTI(I+1)+C2*HTI(I))/(C1+C2)
      VROU(L)=(C1*VROUI(I+1)+C2*VROUI(I))/(C1+C2)
      GO TO 135
  130 CONTINUE
  131 INW1=INWALL+1
      DO 134 I=INW1,ITOT
      C1=ZRL(L)-RI(I)
      C2=RI(I+1)-ZRL(L)
      IF (C1*C2) 134,132,132
  132 PT(L)=(C1*PTI(I+1)+C2*PTI(I))/(C1+C2)
      HT(L)=(C1*HTI(I+1)+C2*HTI(I))/(C1+C2)
      VROU(L)=(C1*VROUI(I+1)+C2*VROUI(I))/(C1+C2)
      GO TO 135
  134 CONTINUE
  135 CONTINUE
      DO 140 L=1,LMAX
      DO 140 K=1,KMAX
      PTOT(L,K)=PT(L)
      HTOT(L,K)=HT(L)
      VOU(L,K)=VROU(L)*SIN(TH(K))
      WOU(L,K)=VROU(L)*COS(TH(K))
  140 CONTINUE
  145 CONTINUE
      IF (ICRUDE.NE.0) GO TO 190
      IF (ITOT.EQ.0) GO TO 155
      CALL LKPGAS(1,2)
      DO 150 K=1,KMAX
      DO 150 L=1,LMW
      PCTOT=(PC(1)/PTOT(L,K))**((GAMMA-1.)/GAMMA)
      VLS=2.*HTOT(L,K)*(1.-PCTOT)/(GAMMA-1.)
      VL=SQRT(VLS)
      Q(L,1,K)=PTOT(L,K)/HTOT(L,K)*(PC(1)/PTOT(L,K))**(1.0/GAMMA)
      Q(L,2,K)=Q(L,1,K)*VL/SQRT(1.+VOU(L,K)**2+WOU(L,K)**2)
      Q(L,3,K)=Q(L,2,K)*VOU(L,K)
      Q(L,4,K)=Q(L,2,K)*WOU(L,K)
      T=HTOT(L,K)*PCTOT
      Q(L,5,K)=Q(L,1,K)*(T/(GAMMA*(GAMMA-1.))+VLS/2.)
  150 CONTINUE
      CALL LKPGAS(1,1)
  155 CONTINUE
      IF(ICRUDE.NE.0) GO TO 190
      IF(KREADY.GT.0) CALL SIDWIC
      CONTINUE
C     BOUNDARY LAYER THICKNESS FOR ADIABATIC B.C.
      IF (IWRIT.NE.0) WRITE (6,165)
  165 FORMAT(//T4,1HJ,T11,3HUCJ,T24,3HTCJ,T37,3HUEJ,T50,3HTEJ,
     1 T62,5HDELTJ,T74,6HDELTZJ)
C
      SJ=0.
      CALL LKPGAS(1,2)
      XXX=Q(1,6,1)
      CALL GEOM(XXX,AJ,ZZT)
      DELT(1)=FN/(1.+FN)*ZZT
      DO 185 J=1,JMAX
      CALL LKPGAS(J,2)
      XJ=Q(LMAX,13,1)
      YJ=Q(LMAX,14,1)
      ZJ=Q(LMAX,15,1)
      UE(J)=UC(J)*(1.+(ZJ/XJ)**2)**.5
      TE(J)=1.-(GAMMA-1.)/2.*UE(J)**2
      FJ=(2.+TE(J))/(UE(J)**5*TE(J)**((2.-GAMMA)/(GAMMA-1.)))
      IF(J.EQ.1)F1=FJ
      GJ=UE(J)**9*TE(J)**((4.-3.*GAMMA)/(GAMMA-1.))*(XJ*XJ+ZJ*ZJ)**.5
      IF (J.EQ.1) GO TO 170
      SJ=SJ+.5*(GJ+GJ1)
      DELT(J)=FJ*((DELT(1)/F1)**2+(4./(3.*RE))*SJ)**.5
  170 DELTZ(J)=DELT(J)*(1.+(ZJ/XJ)**2)**.5
      GJ1=GJ
      IF (IWRIT.NE.0) WRITE (6,180)J,UC(J),TC(J),UE(J),TE(J),DELT(J),DEL
     1TZ(J)
  180 FORMAT(2X,I2,6(2X,1PE11.4))
  185 CONTINUE
      GO TO 195
  190 CALL CRUDIC
  195 CONTINUE
  999 RETURN
      END
*DECK INPUT
      SUBROUTINE INPUT
*CALL COM1
      DATA LWF/1/
C     NOPT
C            0   EXTERNAL 2-D BOUNDARY LAYERS
C            1   INTERNAL FLOW IN 2-D NOZZLES
C            2   AXIZYMMETRIC NOZZLES  AXIS IS AT Y=Z=0  (THE CARTESIAN
C                    L=1,K=1,KMAX
C                PURE INTERNAL FLOW OR COMBINED EXTERNAL/INTERNAL FLOW
C                FOR KW>0 OR LW>0  SET ICRUDE=1
C                FOR JL1WU > 0 SET ICRUDE=1
C            3   ARBITRARY NONAXISYMMETRIC NOZZLES
C                FOR KW > 0 OR LW > 0 SET ICRUDE =1
C
C     IRGRID
C            0   COMPUTE THE GRID
C            1   READ IN THE GRID FROM A FILE PREPARED BY RGRID
C
C     ICRUDE
C            0   USE THE CODE INITQ TO GET THE INITIAL Q'S
C            1   USE THE CODE CRUDIC TO GET THE INITIAL Q'S
      READ (5,10)NMAX,JMAX,KMAX,LMAX,LAMIN,INVISC,J1BC,JMAXBC,KPLANE,K1B
     1C,JK1WL,JK1WU,KW,JKW,KMAXBC
      READ (5,10)L1BC,JL1WL,JL1WU,LW,JLW,LMAXBC,NRST,IWRIT,NGRI,NP,KVIS
     1,LVIS,KLVIS,INFLT,ISUTH,NROUT
      READ (5,15)DT,FSMACH,RMACH,RE,PR,RTDEGK,FSP,FST
      READ (5,15)GAMMA,RMUEXP,TW,CNBR,DTFAC,RM,SMU,OMEGA
   10 FORMAT(16I5)
   15 FORMAT(8F10.0)
      READ (5,10)NOPT,JREADX,IGEOM,KREADY,IRGRID,ICRUDE,ITOT,INWALL
      READ (5,15)XZERO,XMAX,FN,YMAX
      IF (JREADX.GT.0) READ (5,15)(X(J),J=1,JREADX)
      IF (KREADY.GT.0) READ (5,15)(YKR(K),K=1,KREADY)
      IF (ITOT.EQ.0) GO TO 25
      DO 20 I=1,ITOT
      READ (5,15)RI(I),PTI(I),HTI(I),VROUI(I)
   20 CONTINUE
   25 ALP=0.
      ITMAX=NMAX
      WRITE (6,30)NMAX,JMAX,KMAX,LMAX,LAMIN,INVISC,J1BC,JMAXBC,KPLANE,K1
     1BC,JK1WL,JK1WU,KW,JKW,KMAXBC
      WRITE (6,35)L1BC,JL1WL,JL1WU,LW,JLW,LMAXBC,NRST,IWRIT,NGRI,NP,KVIS
     1,LVIS,KLVIS,INFLT,ISUTH,NROUT
      WRITE (6,40)DT,FSMACH,RMACH,RE,PR,RTDEGK,FSP,FST
      WRITE (6,45)GAMMA,RMUEXP,TW,CNBR,DTFAC,RM,SMU,OMEGA
   30 FORMAT(122H1    NMAX    JMAX    KMAX    LMAX    LAMIN  INVISC   J1
     1BC   JMAXBC  KPLANE   K1BC    JK1WL   JK1WU    KW      JKW   KMAXB
     1C     /16I8)
   35 FORMAT(//132H     L1BC    JL1WL   JL1WU    LW      JLW   LMAXBC
     1 NRST   IWRIT   NGRI     NP      KVIS    LVIS   KLVIS   INFLT   IS
     2UTH    NROUT         /16I8)
   40 FORMAT(//7X,2HDT,10X,6HFSMACH,10X,5HRMACH
     1,12X,2HRE,13X,2HPR,11X,6HRTDEGK,10X,3HFSP,13X,3HFST,/1P8E15.7)
   45 FORMAT(//5X,5HGAMMA,10X,6HRMUEXP,11X,2HTW,12X,4HCNBR,10X,5HDTFAC,
     113X,2HRM,12X,3HSMU,11X,5HOMEGA/1P8E15.7///)
      WRITE (6,50)NOPT,JREADX,IGEOM,KREADY,IRGRID,ICRUDE,ITOT,INWALL
   50 FORMAT(/  66H     NOPT  JREADX   IGEOM  KREADY  IRGRID  ICRUDE
     1ITOT  INWALL              /16I8    )
      WRITE (6,55)XZERO,XMAX,FN,YMAX
   55 FORMAT(/5X,5HXZERO,10X,4HXMAX,13X,2HFN,12X,4HYMAX,
     1     /1P4E15.7)
      IF (JREADX.GT.0) WRITE (6,60)(X(J),J=1,JREADX)
   60 FORMAT(/8H  X(J)=  (8F10.5))
      IF (KREADY.GT.0) WRITE (6,65)(YKR(K),K=1,KREADY)
   65 FORMAT(8H  Y(K)=   (8F10.5))
      IF (ITOT.EQ.0) GO TO 85
      WRITE (6,70)
   70 FORMAT(T4,1HI,T16,2HRI,T28,3HPTI,T41,3HHTI,T53,5HVROUI)
      DO 80 I=1,ITOT
      WRITE (6,75)I,RI(I),PTI(I),HTI(I),VROUI(I)
   75 FORMAT(2X,I2,6X,4(2X,1PE11.4))
   80 CONTINUE
   85 CONTINUE
      IF(IRGRID.EQ.0) GO TO 110
      IF(NOPT.NE.3) GO TO 110
      WRITE(6,89)
   89 FORMAT(T8,1HL,T15,1HK,T24,4HPTOT,T38,4HHTOT,T52,3HVOU,T65,3HWOU)
      NKL=KMAX*LMAX
      DO 100 I=1,NKL
      READ(5,90) L,K,PTOT(L,K),HTOT(L,K),VOU(L,K),WOU(L,K)
   90 FORMAT(2I5,4F10.0)
      WRITE(6,95) L,K,PTOT(L,K),HTOT(L,K),VOU(L,K),WOU(L,K)
   95 FORMAT(4X,2(I5,2X),4(2X,1PE11.4))
  100 CONTINUE
  110 CONTINUE
      RETURN
      END
*DECK LAGRAN
      SUBROUTINE LAGRAN (XX,X,FT)
      DIMENSION X(4),FT(4),A(4),B(4),C(4),D(4),E(4)
      DO 5 I=1,4
      A(I)=XX-X(I)
      B(I)=X(1)-X(I)
      C(I)=X(2)-X(I)
      D(I)=X(3)-X(I)
    5 E(I)=X(4)-X(I)
      IF (XX.GT.X(2)) GO TO 7
      FT(4)=0.
      FT(1)=(A(2)*A(3))/(B(2)*B(3))
      FT(2)=(A(1)*A(3))/(C(1)*C(3))
      FT(3)=(A(1)*A(2))/(D(1)*D(2))
      RETURN
    7 IF (XX.LT.X(3)) GO TO 8
      FT(1)=0.
      FT(2)=(A(3)*A(4))/(C(3)*C(4))
      FT(3)=(A(2)*A(4))/(D(2)*D(4))
      FT(4)=(A(2)*A(3))/(E(2)*E(3))
      RETURN
    8 FT(1)=(A(2)*A(3)*A(4))/(B(2)*B(3)*B(4))
      FT(2)=(A(1)*A(3)*A(4))/(C(1)*C(3)*C(4))
      FT(3)=(A(1)*A(2)*A(4))/(D(1)*D(2)*D(4))
      FT(4)=(A(1)*A(2)*A(3))/(E(1)*E(2)*E(3))
      RETURN
      END
*DECK LJPGAS
      SUBROUTINE LJPGAS(K,N)
*CALL COM1
      CALL DMPAST(13,(K-1)*NLROW,1)
      DO 10 J=1 ,JMAX
      IF(N.EQ.1)  CALL DMWAST(13,Q(1,1,J),NLROW)
      IF(N.EQ.2)  CALL DMRAST(13,Q(1,1,J),NLROW)
      CALL DMPAST(13,NLSKIP,-1)
   10 CONTINUE
      RETURN
      END
*DECK LKPGAS
      SUBROUTINE LKPGAS(J,N)
*CALL COM1
      CALL DMPAST(13,(J-1)*NKLP,1)
      IF(N.EQ.1)  CALL DMWAST(13,Q,NKLP)
      IF(N.EQ.2)  CALL DMRAST(13,Q,NKLP)
      RETURN
      END
*DECK MAIN
      PROGRAM NOZLIC(INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT,TAPE2,TAPE15,
     1   TAPE3)
C     MAIN ROUTINE TO SET UP GRID AND INITIALIZE FLOW VARIABLES
      DIMENSION IDPARS(4)
      IDPARS(1)=0
      IDPARS(2)=0
      IDPARS(3)=0
      IDPARS(4)=0
      CALL DMHAST(3,0,0)
      CALL DMDAST(13,0,IDPARS)
      CALL INPUT
      CALL NDLPTS
      CALL INITQ
      CALL OUTPUT
      STOP
      END
*DECK NDLPTS
      SUBROUTINE NDLPTS
*CALL COM1
      DATA LWF/1/,JT/0/
      ZT=0.
C
C    ANY CHANGE IN SIZE OF Q ARRAY MUST BE REFLECTED IN THE FOLLOWING
C   FIVE PARAMETERS
C
      NMAX=16
      NOL=32
      NLROW=NMAX*NOL
      NKLP=NMAX*KMAX*NOL
      NLSKIP=NKLP-NLROW
      PI=4.*ATAN(1.)
      JWMAX=JMAX
      IF(NOPT.GT.0 .AND. FN.NE.0) FN=(1.0-FN)/FN
      ETAE=6.0*(1.0+0.07*FSMACH*(0.2+FSMACH))
      DO 95 J=1,JMAX
      IF (IRGRID.EQ.0) GO TO 20
      READ(3) Q(1,6,1),((Q(L,7,K),Q(L,8,K),K=1,KMAX),L=1,LMAX)
      DO 10 L=1,LMAX
      DO 10 K=1,KMAX
   10 Q(L,6,K)=Q(1,6,1)
C
C... SEARCH FOR THROAT
      IF (Q(1,6,1).NE.0) GO TO 15
      LL=LMAX
      IF(LW.GT.0) LL=LW
      ZTSAVE=Q(LL,8,1)-Q(1,8,1)
      JT=J
   15 CONTINUE
      GO TO 90
   20 CONTINUE
      DO 75 K=1,KMAX
      TH(1)=0.
      YJKL=0.
      IF (KMAX.EQ.1) GO TO 25
      TH(K)=PI/2.*FLOAT(K-1)/FLOAT(KMAX-1)
      YJKL=YMAX*FLOAT(K-1)/FLOAT(KMAX-1)
   25 CONTINUE
      DO 75 L=LWF,LMAX
      IF (JREADX.GT.0) GO TO 30
      Q(L,6,K)=XZERO+FLOAT(J-1)/FLOAT(JMAX-1)*(XMAX-XZERO)
      GO TO 35
   30 Q(L,6,K)=X(J)
   35 CONTINUE
      CALL STRCH(J,K,L,ZFAC)
      IF (NOPT.LT.2) GO TO 50
      XXX=Q(L,6,K)
      IF (LW.GT.0.AND.L.GT.LW) GO TO 40
      RJL=RWFUNC(XXX)*ZFAC
      GO TO 45
   40 RJL=RWOUT(XXX)+(RMAX(XXX)-RWOUT(XXX))*ZFAC
   45 Q(L,7,K)=RJL*SIN(TH(K))
      Q(L,8,K)=RJL*COS(TH(K))
      IF(K.EQ.1 .AND. J.EQ.1) RL(L)=RJL
      GO TO 75
   50 IF (KREADY.GT.0) GO TO 55
      Q(L,7,K)=YJKL
      GO TO 60
   55 IF(K.LE.KREADY) Q(L,7,K)=YKR(K)
   60 IF (NOPT.NE.0) GO TO 65
      ZZ=ETAE*SQRT(Q(L,6,K)/RE)
      GO TO 70
   65 XXX=Q(L,6,K)
      CALL GEOM(XXX,AA,ZZ)
   70 Q(L,8,K)=ZZ*ZFAC
   75 CONTINUE
      IF(KREADY.GT.0 .AND. KREADY.LT.KMAX) CALL YSTRCH(YKR(KREADY))
      CONTINUE
C   SEARCH FOR THROAT
C    SAVE A Z IN CASE JT=1   WHEN YOU CAN'T FIND AN  X=0.
      IF(J.EQ.1) ZTSAVE=Q(LMAX,8,1)
      IF (Q(1,6,1).NE.0) GO TO 80
      JT=J
      LL=LMAX
      IF(LW.GT.0) LL=LW
      ZTSAVE=Q(LL,8,1)
      GO TO 85
   80 CONTINUE
   85 CONTINUE
   90 CONTINUE
C     IF(NOPT.EQ.2) CALL SCALE
          CALL LKPGAS(J,1)
   95 CONTINUE
      IF(JT.EQ.0) JT=1
      WRITE (6,100)JT
  100 FORMAT(2X,21HNOZZLE THROAT AT JT= I3)
      IF (NOPT.LT.1) GO TO 110
      IF(NOPT.GT.1) ZT=ZTSAVE
      DO 105 J=1,JMAX
      CALL LKPGAS(J,2)
      CALL SCALE
      CALL LKPGAS(J,1)
  105 CONTINUE
  110 CONTINUE
      RETURN
      END
*DECK OUTPUT
      SUBROUTINE OUTPUT
*CALL COM1
      IT=0
      GD=GAMMA*(GAMMA-1.)
      TAU=0.0
      CNBR=0.0
      NK=0
      ND2=KMAX*LMAX
      WRITE(2) KMAX,JMAX,LMAX,ITMAX,LMAXBC,L1BC,FSMACH,GAMMA,RE,SMU,DT
     1                                                      ,ALP,CNBR,PR
      WRITE(2) IT,TAU,DT,NK
      DO 90 J=1,JMAX
      CALL LKPGAS(J,2)
      IF (IWRIT.EQ.0) GO TO 40
      DO 35 K=1,KMAX
      WRITE (6,25)J,K
   25 FORMAT(1H0,2X,2HJ=,I3,2X,2HK=,I3,2X,1HL,6X,1HX,11X,1HY,11X,1HZ
     1  ,6X,6HR/RREF,5X,6HU/AREF,5X,6HV/AREF,5X,6HW/AREF,5X,6HT/TREF,
     1 5X,6HP/PREF,5X,3HENT)
      DO 35 L=1,LMAX
      R = Q(L,1,K)
      RR = 1./R
      U = Q(L,2,K)*RR
      V = Q(L,3,K)*RR
      W = Q(L,4,K)*RR
      E = Q(L,5,K)
      S2=0.0
      IF(ABS(U).GT.1.0E-17) S2=S2+U**2
      IF(ABS(V).GT.1.0E-17) S2=S2+V**2
      IF(ABS(W).GT.1.0E-17) S2=S2+W**2
      PP = GD*(E-.5*R*S2)
      TT=PP*RR
      ENT = PP/(ABS(R))**GAMMA
      WRITE (6,30)L,Q(L,6,K),Q(L,7,K),Q(L,8,K),R,U,V,W,TT,PP,ENT
   30 FORMAT(1H ,14X,I3,10F11.6)
   35 CONTINUE
   40 CONTINUE
   50 WRITE(2) (((Q(L,N,K),L=1,LMAX),N=1,8),K=1,KMAX)
   90 CONTINUE
C     IF(NOPT.EQ.1) WRITE(3)EMC,UC,PC,TC,UE,DELT,DELTZ
      RETURN
      END
*DECK QCALC
      SUBROUTINE QCALC(J,K,L,HT,PT,P)
*CALL COM1
      XJ=Q(L,13,K)
      YJ=Q(L,14,K)
      ZJ=Q(L,15,K)
      T=HT*(P/PT)**((GAMMA-1.)/GAMMA)
      RHO=P/T
      VLS=2./(GAMMA-1.)*ABS(HT-T)
      V=SQRT(VLS)
      R=SQRT(XJ*XJ+YJ*YJ+ZJ*ZJ)
      Q(L,1,K)=RHO
      Q(L,2,K)=RHO*V*XJ/R
      Q(L,3,K)=RHO*V*YJ/R
      Q(L,4,K)=RHO*V*ZJ/R
      Q(L,5,K)=RHO*(T/(GAMMA*(GAMMA-1.))+VLS/2.)
      RETURN
      END
*DECK QDRTR
      SUBROUTINE QDRTR(ENTGRL,ENTGRD,DLT,IL,IU)
      DIMENSION ENTGRD(1)
C   1-D TRAPEZOIDAL QUADRATURE. COMPUTES DEFINITE INTEGRAL,ENTGRL,
C   OF INTEGRAND,ENTGRD(I),BETWEEN LIMITS IL,IU.
C
      ENTGRL=0.5*(ENTGRD(IL)+ENTGRD(IU))
      IF((IU-IL).LT.2) RETURN
      ILP=IL+1
      IUM=IU-1
      DO 1 I=ILP,IUM
    1 ENTGRL=ENTGRL+ENTGRD(I)
      ENTGRL=ENTGRL*DLT
      RETURN
      END
*DECK QZERO
      SUBROUTINE QZERO(J,K,L,HT,PT,P)
*CALL COM1
      T=HT*(P/PT)**((GAMMA-1.)/GAMMA)
      RHO=P/T
      Q(L,1,K)=RHO
      Q(L,2,K)=0.
      Q(L,3,K)=0.
      Q(L,4,K)=0.
      Q(L,5,K)=RHO*T/(GAMMA*(GAMMA-1.))
      RETURN
      END
*DECK RMAX
      FUNCTION RMAX(XIN)
*CALL COM1
      DIMENSION XINPUT(28),RIN(28)
      DATA XINPUT/-34.5,-29.5,-24.5,-19.5,-15.5,-12.5,-10.1,-8.4,-7.0,
     1   -5.842,-4.953,-4.064,-3.048,
     2  -2.032,-1.016,0.,1.08,2.17,3.26,4.35,5.44,6.53,7.62,8.7,
     3  10.,11.5,13.,14.5/
      DATA RIN/28*12.62/
      DATA IFIRST/0/
      IF(ZT.EQ.0.) GO TO 5
      IF(IFIRST.NE.0) GO TO 5
      IFIRST=1
      DO 2 J=1,JMAX
      XINPUT(J)=XINPUT(J)/ZT
      RIN(J)=RIN(J)/ZT
    2 CONTINUE
    5 CONTINUE
      DO 10 J=1,JMAX
      IF(XIN.NE.XINPUT(J)) GO TO 10
      JFIND=J
      GO TO 20
   10 CONTINUE
      GO TO 990
   20 CONTINUE
      RMAX=RIN(JFIND)
      RETURN
  990 WRITE(6,999)
  999 FORMAT(2X,35H***ERROR IN RMAX FUNCTION ROUTINE**)
      STOP
      END
*DECK RWFUNC
      FUNCTION RWFUNC(XIN)
*CALL COM1
      DIMENSION XINPUT(28),RIN(28)
      DATA XINPUT/-34.5,-29.5,-24.5,-19.5,-15.5,-12.5,-10.1,-8.4,-7.0,
     1   -5.842,-4.953,-4.064,-3.048,
     2  -2.032,-1.016,0.,1.08,2.17,3.26,4.35,5.44,6.53,7.62,8.7,
     3  10.,11.5,13.,14.5/
      DATA RIN/4*6.4315,6.336,6.194,5.996,5.820,5.653,5.436,5.019,4.585,
     1  4.229,3.993,3.856,13*3.81/
      DATA IFIRST/0/
      IF(ZT.EQ.0.) GO TO 5
      IF(IFIRST.NE.0) GO TO 5
      IFIRST=1
      DO 2 J=1,JMAX
      XINPUT(J)=XINPUT(J)/ZT
      RIN(J)=RIN(J)/ZT
    2 CONTINUE
    5 CONTINUE
      DO 10 J=1,JMAX
      IF(XIN.NE.XINPUT(J)) GO TO 10
      JFIND=J
      GO TO 20
   10 CONTINUE
      GO TO 990
   20 CONTINUE
      RWFUNC=RIN(JFIND)
      RETURN
  990 WRITE(6,999) XIN,XINPUT
  999 FORMAT(2X,37H***ERROR IN RWFUNC FUNCTION ROUTINE**/(8E12.5))
      STOP
      END
*DECK RWOUT
      FUNCTION RWOUT(XIN)
*CALL COM1
      DIMENSION XINPUT(28),RIN(28)
      DATA XINPUT/-34.5,-29.5,-24.5,-19.5,-15.5,-12.5,-10.1,-8.4,-7.0,
     1   -5.842,-4.953,-4.064,-3.048,
     2  -2.032,-1.016,0.,1.08,2.17,3.26,4.35,5.44,6.53,7.62,8.7,
     3  10.,11.5,13.,14.5/
      DATA RIN/4*7.62,7.54624,7.38481,7.1898,
     1  7.01605,6.85065,6.69854,6.57232,
     2  6.43787,6.27408,6.09943,5.91386,5.71732,
     3  5.49628,5.26045,5.01173,4.75002,4.47521,
     4   4.18718,6*3.812/
      DATA IFIRST/0/
      IF(ZT.EQ.0) GO TO 5
      IF(IFIRST.NE.0) GO TO 5
      IFIRST=1
      DO 2 J=1,JMAX
      XINPUT(J)=XINPUT(J)/ZT
      RIN(J)=RIN(J)/ZT
    2 CONTINUE
    5 CONTINUE
      DO 10 J=1,JMAX
      IF(XIN.NE.XINPUT(J)) GO TO 10
      JFIND=J
      GO TO 20
   10 CONTINUE
      GO TO 990
   20 CONTINUE
      RWOUT=RIN(JFIND)
      RETURN
  990 WRITE(6,999)
  999 FORMAT(2X,36H***ERROR IN RWOUT FUNCTION ROUTINE**)
      STOP
      END
*DECK SCALE
      SUBROUTINE SCALE
*CALL COM1
      DIMENSION R(13)
      EQUIVALENCE (XMAX,R(1))
      DATA IFIRST/0/
       IOP=2
      IF(NOPT.EQ.1) IOP=13
      DO 10 L=1,LMAX
      DO 10 K=1,KMAX
      Q(L,6,K)=Q(L,6,K)/ZT
      Q(L,7,K)=Q(L,7,K)/ZT
      Q(L,8,K)=Q(L,8,K)/ZT
   10 CONTINUE
      IFIRST=IFIRST+1
       IF(IFIRST.NE.JWMAX) GO TO 30
      ZTT=ZT
      DO 20 I=1,IOP
      R(I)=R(I)/ZTT
   20 CONTINUE
   30 CONTINUE
      RETURN
      END
*DECK SIDWIC
      SUBROUTINE SIDWIC
C
C      SIDE WALL INITIAL CONDITIONS
*CALL COM1
      KE=(KMAX+1)/2
      DO 70 J=1,JMAX
      CALL LKPGAS(J,2)
      DO 65 L=1,LMAX
      U0=Q(L,2,KE)/Q(L,1,KE)
      DO 65 K=KE,KMAX
      UK=U0*(FLOAT(KMAX-K)/FLOAT(KMAX-KE))
      IF (TW.GT.0) GO TO 55
      TL=TC(J)*(1.+(GAMMA-1.)/2.*EMC(J)**2*(1.-(UK/UC(J))**2))
      GO TO 60
   55 TL=TW+(UK/UC(J))*(-TW+TC(J)*(1.+(GAMMA-1.)/2.*EMC(J)**2*(1.-UK/
     1  UC(J))))
   60 CONTINUE
      RHOL=PC(J)/TL
      EL=PC(J)/(GAMMA*(GAMMA-1.))+RHOL*UK*UK/2.
      Q(L,1,K)=RHOL
      Q(L,2,K)=RHOL*UK
      Q(L,3,K)=0.
      Q(L,4,K)=0.
      Q(L,5,K)=EL
   65 CONTINUE
      CALL LKPGAS(J,1)
   70 CONTINUE
      RETURN
      END
*DECK STRCH
      SUBROUTINE STRCH(J,K,L,ZFAC)
*CALL COM1
      DATA IFIRST/0/
      IF(IFIRST.NE.0) GO TO 5
      IFIRST=1
      IFN=0
      IF(FN.NE.0.) IFN=1
    5 KL=(L-1)*KMAX+K
      IF(IFN.NE.0) GO TO 12
      XXX=Q(L,6,K)
      IF(LW.NE.0 .AND. L.GT.LW) GO TO 11
      FN=DELI(XXX)/RWFUNC(XXX)
      GO TO 12
   11 FN=DELOUT(XXX)/(RMAX(XXX)-RWOUT(XXX))
   12 IF(LW.GT.0) GO TO 14
      LE=(LMAX+1)/2
      ZETA=FLOAT(L-1)/FLOAT(LMAX-1)
      ZETAE=FLOAT(LE-1)/FLOAT(LMAX-1)
      GO TO 30
   14 IF(L.GT.LW) GO TO 20
      LE=(LW+1)/2
      ZETA=FLOAT(L-1)/FLOAT(LW-1)
      ZETAE=FLOAT(LE-1)/FLOAT(LW-1)
      GO TO 30
   20 LE=(LMAX-LW+1)/2+LW+1
      ZETA=1.-FLOAT(L-LW-1)/FLOAT(LMAX-LW-1)
      ZETAE=FLOAT(LE-LW-1)/FLOAT(LMAX-LW-1)
   30 ZFAC=(FN+1.)*(FN**(ZETA/(1.-ZETAE))-1.)/(FN**(1./(1.-ZETAE))-1.)
      IF(NOPT.LT.1) GO TO 99
      ZFAC=ZFAC/(FN+1.)
      IF(L.GT.LW.AND.LW.GT.0) ZFAC=1.-ZFAC
   99 RETURN
      END
*DECK TRPOL8
      SUBROUTINE TRPOL8(XX,X,Y,I,YY)
      DIMENSION X(1),A(4),Y(1)
      IF(I.EQ.1) GO TO 100
      CALL LAGRAN(XX,X(I-1),A)
      YY=A(1)*Y(I-1)+A(2)*Y(I)+A(3)*Y(I+1)+A(4)*Y(I+2)
      RETURN
  100 YY=Y(1)+(Y(2)-Y(1))*(XX-X(1))/(X(2)-X(1))
      RETURN
      END
*DECK XXM
      SUBROUTINE XXM(L,J,K1,K2)
*CALL COM1
C
C  XI METRICS FORMED FOR A K,L LINE IN J
C
C
C  SYMMETRY
C
      DO 10 K=K1,K2
      CALL DKMET(J,K,L,XK,YK,ZK)
      CALL DLMET(J,K,L,XL,YL,ZL)
      XX(K,1) = YK*ZL-ZK*YL
      XX(K,2) = ZK*XL-XK*ZL
      XX(K,3) = XK*YL-YK*XL
   10 CONTINUE
      RETURN
      END
*DECK XYZXI
      SUBROUTINE XYZXI(KMAX,JMAX,LMAX)
      COMMON /C1/ Q(32,16,32)
      DX2=.5
      DO 100 K=1,KMAX
      CALL LJPGAS(K,2)
      DO 70 L=1,LMAX
      DO 70 J=1,JMAX
      JP=J+1
      JR=J-1
C     XI DERIVATIVES OF X,Y,Z
      IF(J.EQ.1) GO TO 50
      IF(J.EQ.JMAX) GO TO 51
      Q(L,13,J) = (Q(L,6,JP)-Q(L,6,JR))*DX2
      Q(L,14,J) = (Q(L,7,JP)-Q(L,7,JR))*DX2
      Q(L,15,J) = (Q(L,8,JP)-Q(L,8,JR))*DX2
      GO TO 70
   50 J1 = J+1
      Q(L,13,J)= Q(L,6,J1)-Q(L,6,J)
      Q(L,14,J)= Q(L,7,J1)-Q(L,7,J)
      Q(L,15,J)= Q(L,8,J1)-Q(L,8,J)
      GO TO 70
   51 J1 = J-1
      Q(L,13,J)= Q(L,6,J)-Q(L,6,J1)
      Q(L,14,J)= Q(L,7,J)-Q(L,7,J1)
      Q(L,15,J)= Q(L,8,J)-Q(L,8,J1)
   70 CONTINUE
      CALL LJPGAS(K,1)
  100 CONTINUE
      RETURN
      END
*DECK YSTRCH
      SUBROUTINE YSTRCH(YKREAD)
C      ROUTINE TO EXPONENTIALLY STRETCH THE Y GRID FROM Y(KREADY+1) TO Y
C
*CALL COM1
      FD(W)=((W-1.)*EXP(W)+1.)/(W*W)
      F(W)=(EXP(W)-1.)/W-1./BETA
      DELE=1./(KMAX-KREADY)
      LM=LMAX-1
      DELZ=Q(LMAX,8,1)-Q(LM,8,1)
      BETA=DELZ/((YMAX-YKREAD)*DELE)
C
C     NEWTON ITERATION FOR Y STRETCHING COEFFICIENT
      W1=20.
      N=0
   10 W2=W1-F(W1)/FD(W1)
      N=N+1
      ERR=ABS((W2-W1)/W2)
      IF (ERR.LT.1.E-5) GO TO 20
      W1SAVE=W1
      W1=W2
      IF (N.LT.20) GO TO 10
C
C     FAILURE TO CONVERGE
C
      WRITE (6,15)W1SAVE,W2,ERR,N,YMAX,YKREAD,DELE,DELZ,BETA
   15 FORMAT(81H****FAILURE TO CONVERGE IN NEWTON ITERATION FOR Y STRETC
     1HING COEFFICIENT OMEGA***   /2X,3HW1=E10.3,4H W2=E10.3,5H ERR=,
     2  E10.3,3H N=I2,/2X,6H YMAX= E10.3,8H YKREAD=E10.3,
     3  6H DELE=  E10.3,  6H DELZ=E10.3,6H BETA=E10.3)
      GO TO 40
   20 CONTINUE
      OMEGA=W2
      OMEINV=1./(1.-EXP(-OMEGA))
      KR1=KREADY+1
        DO 30 K=KR1,KMAX
        ETAK=FLOAT(K-KREADY)/FLOAT(KMAX-KREADY)
        EXPOET=(1.-EXP(-OMEGA*ETAK))*OMEINV
          DO 25 L=1,LMAX
          Q(L,7,K)=YKREAD+(YMAX-YKREAD)*EXPOET
   25     CONTINUE
   30   CONTINUE
   35 CONTINUE
      RETURN
C*** ERROR STOP
   40 STOP
      END
*COMDECK    CARDS
      COMMON /CARDS/
     A    ITEMS,    ITPREC,   KCARDS,   KDOREC,   KIRECS,
     B    LASCOL,   LSOUGT,   LVJUMP,   L1SENT,   L2SENT,   NILERR,
     C    IREC,     IDAT
      INTEGER       IREC(200), IDAT(200)
      REAL          REC(1)
      EQUIVALENCE   (IREC,REC)
*COMDECK    CDMERR
      COMMON /CDMERR/
     A    DMERCD,   DMERCM,   DMERLC,   DMERPM,   IOMERH,   IEHSAV
      INTEGER       DMERCD,   DMERCM,   DMERLC,   DMERPM
      COMMON /CDMETS/
     A    TRARGS,   TROPID,   TRINST,   TRARGL,
     B    TRSTSZ,   TRTOPM,   TRTOPS,   TRSTAK
      INTEGER       TRARGS,   TROPID,   TRINST,   TRARGL(10)
      INTEGER       TRSTSZ,   TRTOPM,   TRTOPS,   TRSTAK(48)
*COMDECK    CDMERRA
          USE /CDMERR/
DMERCD    BSS       1
DMERCM    BSS       1
DMERLC    BSS       1
DMERPM    BSS       1
IOMERH    BSS       1
IEHSAV    BSS       1
          USE /CDMETS/
TRARGS    BSS       1
TROPID    BSS       1
TRINST    BSS       1
TRARGL    BSS       10
TRSTSZ    BSS       1
TRTOPM    BSS       1
TRTOPS    BSS       1
TRSTAK    BSS       48
*COMDECK    CDMASTA
          USE       /CDMAST/
MAXLDI    SET       16D
ASTDIM    BSS       1
          BSS       7              ASTOSD(1-7)
SIZREC    BSS       1              RECORD SIZE IN WORDS (N)
RETCOD    BSS       1              RETURN CODE (BITS 0-8 OF FET+0)
EOFCOD    BSS       0
EOICOD    BSS       1              END OF INFORMATION RETURN CODE
STATUS    BSS       1              OPERATION STATUS WORD
DTLERR    BSS       0              DETAILED ERROR CODE (NOS)
TAPERR    BSS       1              DETAILED TAPE ERROR (SCOPE)
RSKCNT    BSS       1              RESIDUAL SKIP COUNT (SCOPE)
NWRDXF    BSS       1              NUMBER OF WORDS XFERRED ON READ/WRITE
ASTCNT    BSS       7
ASTSEC    BSS       8
          IFEQ      OS,SCOPE
ASTSYS    BSSZ      1              SYSTEM IDENTIFIER             (SCOPE)
          ELSE
ASTSYS    DATA      1              SYSTEM IDENTIFIER               (NOS)
          ENDIF
ASTMSG    BSS       9              MESSAGE TEXT AREA
DEVTYP    BSS       1
PRUSIZ    BSS       1
LFNADS    BSS       1
PRUXEI    BSS       1
NWXF      BSS       1
NWXWRT    BSS       1
OUTMIN    BSS       1              (OUT-IN) ON EXIT FROM FETRET$
          BSS       6              SCRATCH
FET       BSS       9              FET PROPER
FETEXT    BSS       3              FET EXTENSION (SCOPE)
ASTQFR    BSS       MAXLDI         QUALIFIERS (USER IDS, OWNERS IDS)
ASTPFN    BSS       MAXLDI         PERMANENT FILENAMES
ASTLFN    BSS       MAXLDI         LOGICAL FILENAMES
ASTEQC    BSS       MAXLDI         EQUIPMENT CODES
ASTOPT    BSS       MAXLDI         ACCESSIBILITY/PERMANENCY OPTIONS
ASTYPE    BSS       MAXLDI         GEN EQUIPMENT TYPE INDICES
ASTUNT    BSS       MAXLDI         UNIT NUMBERS (LEFT FOR COMPATIB)
ASTLOC    BSS       MAXLDI         CURRENT DEVICE LOCATIONS
ASTNXT    BSS       MAXLDI         NEXT (EOI) DEVICE LOCATIONS
ASTLIM    BSS       MAXLDI         DEVICE CAPACITIES
ASTWXR    BSS       MAXLDI         COUNTS OF WORDS READ
ASTWXW    BSS       MAXLDI         COUNTS OF WORDS WRITTEN
*COMDECK    DALCOM
C
      COMMON /CDMDAL/
     $    LDILIB(26),
     $    LIBLDI(4),LIBHDR(4),LIBLIN(4),LIBNSG(4),
     $    LIBLOC(4),LIBNXT(4),LIBOPR(4),LIBSEG(4),
     $    LIBSEQ(4),LIBWRT(4),LININP(16),         LINTOC(16),
     $    MAXDAL,   MCTSEG,   MWHSEG,   MWTSEG,   NAMKEY(4),
     $    NCTSEG,   NRTSEG,   NTLINE,   NWLHDR,   NWTSEG
C
      COMMON /SYMBIO/
     A    CRDFIL,   ERRFIL,   MCHLIN,   MTWLIN,
     B    PLTFIL,   PPLFIL,   PRTFIL,   PUNFIL,   SYSCRD,
     C    SYSPRT,   TTYINP,   TTYPRT,   TXTFMT,   ZIOSCR
      INTEGER       CRDFIL,   ERRFIL,   MCHLIN,   MTWLIN
      INTEGER       PLTFIL,   PPLFIL,   PRTFIL,   PUNFIL,   SYSCRD
      INTEGER       SYSPRT,   TXTFMT(5),ZIOSCR(96)
      LOGICAL       TTYINP,   TTYPRT
C
      COMMON //     IPOOL(1)
      REAL          POOL(1)
      DOUBLE PRECISION        DPOOL(1)
      EQUIVALENCE   (IPOOL,POOL,DPOOL)
*COMDECK    DALTIT
C***********************************************************************
C*    N O S T R A    D A T A    M A N A G E M E N T    S Y S T E M     *
C*                                                                     *
C*    E Z - D A L    BASIC-LEVEL MANAGER OF DIRECT ACCESS LIBRARIES    *
C***********************************************************************
*COMDECK    DMECOM
      COMMON /CDMERR/
     A    DMERCD,   DMERCM,   DMERLC,   DMERPM,   IOMERH,   IEHSAV
      INTEGER       DMERCD,   DMERCM,   DMERLC,   DMERPM
      COMMON /CDMETS/
     A    TRARGS,   TROPID,   TRINST,   TRARGL,
     B    TRSTSZ,   TRTOPM,   TRTOPS,   TRSTAK
      INTEGER       TRARGS,   TROPID,   TRINST,   TRARGL(10)
      INTEGER       TRSTSZ,   TRTOPM,   TRTOPS,   TRSTAK(48)
*COMDECK    IOMACTL
************************************
*  ASSEMBLY CONTROL SPECIFICATIONS *
************************************
SCOPE     EQU       0              *
NOS       EQU       1              *
OS        SET       NOS            *
          SYSCOM    B1             *
*         LIST      S              *
*COMDECK    IOMCOM
C
      COMMON  /CDMAST/        ASTDIM,
     A    ASTOSD,   ASTCNT,   ASTSEC,   ASTSYS,   ASTMSG,   ASTPKT,
     B    ASTQFR,   ASTPFN,   ASTLFN,   ASTEQC,   ASTOPT,   ASTYPE,
     C    ASTUNT,   ASTLOC,   ASTNXT,   ASTLIM,   ASTWXR,   ASTWXW
      INTEGER       ASTDIM,   ASTOSD(14), ASTCNT(7), ASTSEC(8)
      INTEGER       ASTSYS,   ASTMSG(9),ASTPKT(25)
      INTEGER       ASTQFR(16), ASTPFN(16), ASTLFN(16), ASTEQC(16)
      INTEGER       ASTUNT(16), ASTOPT(16), ASTYPE(16)
      INTEGER       ASTLOC(16), ASTNXT(16), ASTLIM(16)
      INTEGER       ASTWXR(16), ASTWXW(16)
*COMDECK    RPMDIB
C
      COMMON /CDMDAT/
     A    ASPBEG,   ASPEND,   ASPLDI,   BOOTNG,
     B    IDXCAT,   IDXLAT,   IDXGAT,   IDXRAT,
     C    KEYCAT,   KEYLAT,   KEYGAT,   KEYRAT,
     D    GIDBUF,   GIDDMS,   GIDTEM,
     E    MSKGID,   MSKLOC,   MSKRID,
     F    RPDIND,   RPDFIX,   RPDNAM,   RPDNUM,
     G    TIMBEG,   TIMDMS,   TIMING,   TYPTAB,
     H    UPCALL,   UPGREF
      INTEGER       ASPBEG,   ASPEND,   ASPLDI
      INTEGER       GIDBUF,   GIDDMS,   GIDTEM
      INTEGER       GIDRES(3),IDXTAB(4),KEYTAB(4),RIDRES(4)
      INTEGER       RPDIND,   RPDFIX,   RPDNAM,   RPDNUM
      INTEGER       RPDTAB(4),TYPTAB(4),UPCALL
      LOGICAL       BOOTNG,   TIMING,   UPGREF
      EQUIVALENCE   (IDXTAB(1),IDXCAT), (RPDTAB(1),RPDIND)
      EQUIVALENCE   (GIDRES(1),GIDBUF), (RIDRES(1),KEYTAB(1),KEYCAT)
*COMDECK    RPMDAT
      DATA          ASPBEG, ASPEND, ASPLDI /18,32,0/
      DATA          BOOTNG /.TRUE./
      DATA          IDXCAT,IDXLAT,IDXGAT,IDXRAT /1,2,3,4/
      DATA          KEYCAT,KEYLAT,KEYGAT,KEYRAT/3HCAT,3HLAT,3HGAT,3HRAT/
      DATA          GIDBUF,GIDDMS,GIDTEM  /4H$BUF,4H$DMS,4H$TEM/
      DATA          MSKGID, MSKRID /2*77777777000000000000B/
      DATA          MSKLOC  /77777777B/
      DATA          RPDTAB / 2, 1, 3, 3/
      DATA          TYPTAB /3RIND, 3RFIX, 3RNAM, 3RNUM/
      DATA          TIMBEG,TIMDMS,TIMING,UPCALL/0.,0.,.FALSE.,0/
      DATA          UPGREF /.FALSE./
*COMDECK    RPMTIT
C***********************************************************************
C*    N O S T R A    D A T A    M A N A G E M E N T    S Y S T E M     *
C*                                                                     *
C*    R P M          R E S O U R C E   P O O L   M A N A G E R         *
C***********************************************************************
*COMDECK    SYMBIO
      COMMON /SYMBIO/
     A    CRDFIL,   ERRFIL,   MCHLIN,   MTWLIN,
     B    PLTFIL,   PPLFIL,   PRTFIL,   PUNFIL,   SYSCRD,
     C    SYSPRT,   TTYINP,   TTYPRT,   TXTFMT,   ZIOSCR
      INTEGER       CRDFIL,   ERRFIL,   MCHLIN,   MTWLIN
      INTEGER       PLTFIL,   PPLFIL,   PRTFIL,   PUNFIL,   SYSCRD
      INTEGER       SYSPRT,   TXTFMT(5),ZIOSCR(96)
      LOGICAL       TTYINP,   TTYPRT
*DECK       DMGASP
C=DECK      DMGASP      DMGASP      MIXED
      SUBROUTINE    DM GASP
     $      (ARG1, ARG2, ARG3)
C
C=PURPOSE   ACCESS METHOD OF NOSTRA-DMS
C=AUTHOR    C. A. FELIPPA
C=VERSION   NOVEMBER 1977
C=EQUIPMENT CDC
C=KEYWORDS  AUXILIARY   STORAGE     MANAGER     I/O
C=KEYWORDS  DATA        MANAGEMENT SYSTEM
C=EASY-SUB  DMABRT      LFNBF       LFNZF       IOMAPF      IOMCLS
C=EASY-SUB  IOMCPF      IOMDPF      IOMEOF      IOMEPF      IOMEVT
C=EASY-SUB  IOMFET      IOMOPN      IOMPOD      IOMPOT      IOMPRU
C=EASY-SUB  IOMPPF      IOMQFC      IOMRPF      IOMRDR      IOMWTR
C=EASY-SUB  IOMTAB      IOMXEI
C=TEST      TESTCIO     TESTPFM
C=USAGE     REFER TO DMGASP REFERENCE MANUAL, LMSC-D626839
C
C                   C O M M O N
C
C=PROCEDURE IOMCOM      CDMETS      CDMERR
*CALL               IOMCOM
*CALL               DMECOM
C
C                   T Y P E   A N D    D I M E N S I O N
C
      INTEGER       ARG1,     ARG2(2),  ARG3(4)
      INTEGER       CDLOC,    DEVICX,   DEVTYP,   EDN(2),   EOFCOD
      INTEGER       QFC(3),   REEL,     RETCOD,   RING,     RSKCNT
      INTEGER       EQCODE,             OPTX,     OPTXA
      INTEGER       PFN,      PFNID,    PFNCY,    PFNRP,    PFNXR
      INTEGER       SECTOR,   SIZREC,   STATUS,   TAPERR,   TYPEX
      INTEGER       TYPIDX,             VRN
C
C                   E Q U I V A L E N C E
C
      EQUIVALENCE   (IDOPER,ASTOSD(1)),  (IOERCD,ASTOSD(2))
      EQUIVALENCE   (DEVICX,ASTOSD(3)),  (TYPEX, ASTOSD(4))
      EQUIVALENCE   (LCARG1,ASTOSD(5)),  (LCARG2,ASTOSD(6))
      EQUIVALENCE   (LOCDEV,ASTOSD(7)),  (SIZREC,ASTOSD(8))
      EQUIVALENCE   (RETCOD,ASTOSD(9)),  (EOFCOD,ASTOSD(10))
      EQUIVALENCE   (STATUS,ASTOSD(11)), (TAPERR,ASTOSD(12))
      EQUIVALENCE   (RSKCNT,ASTOSD(13)), (NWRDXF,ASTOSD(14))
      EQUIVALENCE   (DEVTYP,ASTPKT(1)),  (SECTOR,ASTPKT(2))
      EQUIVALENCE   (QFC,PFNID), (QFC(2),PFN),  (QFC(3),PFNCY)
C
C                   D A T A    I N I T I A L I Z A T I O N
C
      DATA          ASTDIM  /16/
      DATA          (ASTCNT(J),J=1,7)  /7*0/
      DATA          (ASTEQC(J),J=1,16) /16*0/
      DATA          (ASTLFN(J),J=1,16)
     A       /5LTAPE1, 5LTAPE2, 5LTAPE3, 5LTAPE4, 5LTAPE7, 5LTAPE8,
     B        5LTAPE9, 6LTAPE10,6LTAPE11,6LTAPE12,6LTAPE13,6LTAPE14,
     C        6LTAPE15,6LTAPE16,6LTAPE17,6LTAPE18/
      DATA          (ASTOSD(J),J=1,14) /1H ,13*0/
      DATA          (ASTPFN(J),J=1,16) /16*0/
      DATA          (ASTSEC(J),J=1,8)  /4*0,64,64,1,1/
      DATA          (ASTUNT(J),J=1,16)
     A    /1, 2, 3, 4,       7, 8, 9,10,11,12,13,14,15,16,17,18/
      DATA          (ASTYPE(J),J=1,16) /16*4/
      DATA          (ASTWXR(J),J=1,16) /16*0/
      DATA          (ASTWXW(J),J=1,16) /16*0/
      DATA          PFNRP /30/
      DATA          DMERCD, DMERCM, DMERLC, DMERPM, IOMERH /5*0/
C
C
C              INITIALIZATION/CHECKOUT CODE BLOCK
C              COMMON TO ALL ENTRY POINTS
C
  100 CONTINUE
      ASSIGN 250 TO  LJ DEVX
  150 CONTINUE
      DO 160  I = 2,14
        ASTOSD(I) = 0
  160   CONTINUE
      DEVICX =   ARG1
      LDI =      DEVICX
      IF (LDI)                         6100,6100, 180
  180 IF (LDI - ASTDIM)                 200, 200,6100
  200 CONTINUE
      TYPEX =    ASTYPE(LDI) - 4
      TYPIDX =   TYPEX
      SECTOR =   ASTSEC(TYPEX+5)
      EQCODE =   ASTEQC(LDI)
      LFN =      ASTLFN(LDI)
      PFN =      ASTPFN(LDI)
      PFNID =    ASTQFR(LDI)
      OPTX =     ASTOPT(LDI)
      OPTXA =    IABS(OPTX)
      GO TO    LJ DEVX,  (250, 1000, 1800)
  250 CONTINUE
      NEXT =     ASTNXT(LDI)
      LIMIT =    ASTLIM(LDI)
      CDLOC =    ASTLOC(LDI)
      LOCDEV =   CDLOC
      LOCREC =   LOCDEV + 1
      NEWLOC =   LOCREC
C
C              VERIFY DEVICE IS ACTIVE
C
      IF (EQCODE .EQ. 0)               GO TO 6200
      GO TO    LJ TASK,  (800, 1200, 2500, 3000, 3500, 4000)
  800 CONTINUE
C
C=ENTRY     DMDAST      DMDAST    ENTRY
C=USAGE     SEE SECTION 3.1 OF DMGASP REF. MNANUAL, LMSC-D626839
C=PURPOSE   DECLARE (ASSIGN, OPEN) AN AUXILIARY STORAGE DEVICE
C=USAGE     SEE SECTION 3.1 OF DMGASP REF. MANUAL, LMSC-D626839
C
C     ++++++++++++++++++++++
      ENTRY         DM D AST
C     ++++++++++++++++++++++
C
      IDOPER =   6HDMDAST
      ASSIGN 1000 TO  LJ DEVX
      GO TO 150
 1000 CONTINUE
C
C              IF DEVICE IS CURRENTLY ACTIVE, CLOSE IT, THEN OPEN
C
      IF (EQCODE .EQ. 0)               GO TO 1100
      ASSIGN  1100 TO  LJ FAST
      GO TO 1900
 1100 CONTINUE
      EDN(1) =   ARG2(1)
      EDN(2) =   ARG2(2)
      TYPEX =    ARG3(1)
      OPTX =     ARG3(2)
      OPTXA =    IABS(OPTX)
      LIMIT =    ARG3(3)
      IF (LIMIT .LE. 0)                LIMIT =  262144
      REEL =     ARG3(4)
      IF (REEL .EQ. 1H )               REEL = 0
      SECTOR =   ASTSEC(TYPEX+5)
      NEXT =     0
C
C              IF EDNAME IS NZ, PROCESS SUPPLIED IDENTIFIER
C
      CALL       IOM QFC  (EDN,  QFC)
C
C              BRANCH ACCORDING TO EQUIPMENT REQUEST INDEX
C
      NTRKS =    7
      IF (TYPEX+1)                     1200,1250,1400
C
C              --------------------
C              MAGNETIC TAPE DEVICE
C              --------------------
C
 1200 CONTINUE
      NTRKS =    9
 1250 CONTINUE
      RING =     0
      IF (IABS(OPTX)-1)                1280,1300,1320
 1280 CONTINUE
      REEL =     1
 1300 CONTINUE
      RING =     1
 1320 CONTINUE
C     CALL       IOM RMT  (LFN, VRN, RING, 0, NTRKS, 0)
      GO TO 1600
C
C              --------------------
C              DIRECT ACCESS DEVICE
C              --------------------
C
 1400 CONTINUE
      LFN =      ASTLFN(LDI)
      IF (PFN .EQ. 0)                  GO TO 1420
      IF (REEL .NE. 0)                 LFN = LFNZF(REEL)
 1420 CONTINUE
C
      IF (TYPEX - 2)                   1440,7100,7100
 1440 CONTINUE
C
C              SECTOR-ADDRESSABLE MASS STORAGE
C
      IF (OPTXA .LE. 2)                GO TO 1500
      PFN =      AND(PFN,-777777B) .OR. PFNCY .OR. 64*PFNRP
      ASTPFN(LDI) = PFN
C
C              ATTACH PERM FILE TO RUN IF OPTX = 3,4
C
      MODE =     OPTXA - 4
      IF (MODE .GT. 0)                 GO TO 1450
      IF (ASTSYS .NE. 0)               MODE = IABS(MODE)
      CALL       IOM APF  (LFN, PFN, PFNID, MODE)
      IF (STATUS. NE. 0)               GO TO 7100
      NEXT =     IOM PRU  (LFN)
      GO TO 1500
C
C              IF NEW PERM FILE REQUESTED (OPTX GT 5), ISSUE A
C              EQUIPMENT REQUEST ON SCOPE, OR A DEFINE REQUEST ON NOS
C
 1450 CONTINUE
      IF (ASTSYS .EQ. 0)               CALL  IOM RPF  (LFN)
      MCT =      MOD(OPTXA+1,2)*2
      IF (ASTSYS .NE. 0)               CALL  IOM DPF (LFN, PFN, MCT, 0)
      IF (STATUS .NE. 0)               GO TO 7100
C
C              OPEN FILE
C
 1500 CONTINUE
      CALL       IOM OPN  (LFN)
C
 1550 CONTINUE
 1600 CONTINUE
C
C              INSERT DEVICE DESCRIPTORS IN AUX STORAGE TABLE
C
      ASTPFN(LDI) = LFN
      ASTQFR(LDI) = PFNID
      ASTPFN(LDI) = PFN
      ASTLFN(LDI) = LFN
      ASTEQC(LDI) = MAX0(DEVTYP,1)
      ASTYPE(LDI) = TYPEX + 4
      ASTOPT(LDI) = OPTXA
      ASTLIM(LDI) = LIMIT
      ASTLOC(LDI) = 0
      ASTNXT(LDI) = NEXT
      ASTWXR(LDI) = 0
      ASTWXW(LDI) = 0
      GO TO 5000
C
C=ENTRY     DMFAST      DMFAST    ENTRY
C=PURPOSE   FREE (CLOSE, DEACTIVATE) AN AUXILIARY STORAGE DEVICE
C=USAGE     SEE SECTION 3.2 OF DMGASP REF. MANUAL, LMSC-D626839
C
C     ++++++++++++++++++++++
      ENTRY        DM F AST
C     ++++++++++++++++++++++
C
      IDOPER =   6HDMFAST
      ASSIGN 5000 TO  LJ FAST
      ASSIGN 1800 TO  LJ DEVX
      GO TO 150
 1800 CONTINUE
C
      IF (ARG2(1))                     1850,1900,1950
C
C              EVICT CONTENTS OF FILE (ERASE)
C
 1850 CONTINUE
      CALL       IOM EVT  (LFN)
      ASTNXT(LDI) =  0
      GO TO 5000
C
C              RELEASE FILE FROM JOB (FREE DEVICE).  IF OPTX GE 5,
C              CATALOG NEW PERM FILE IF ON SCOPE.
C
 1900 CONTINUE
      IF (ASTSYS .NE. 0)               GO TO 1930
      IF (OPTXA .LE. 2)                GO TO 1930
      IF (OPTXA .GE. 5)                GO TO 1920
      IF (ASTWXW(LDI) .NE. 0)
     $CALL       IOM EPF  (LFN, PFN, 0, 0)
      GO TO 1930
 1920 CONTINUE
      PFNXR =    0
      CALL       IOM CPF  (LFN, PFN, PFNID, PFNXR)
      IF (STATUS .NE. 0)               GO TO 7100
 1930 CONTINUE
C
C              CLOSE FILE
C
      CALL       IOM CLS  (LFN)
      ASTEQC(LDI) = 0
      ASTPFN(LDI) = 0
      GO TO    LJ FAST, (1100, 5000)
C
C              PURGE PERMANENT FILE (DECATALOGUE)
C
 1950 CONTINUE
      CALL       IOM PPF  (LFN, PFN, 0, 0)
      ASTEQC(LDI) = 0
      ASTPFN(LDI) = 0
      GO TO 5000
C
C=ENTRY     DMPAST      DMPAST    ENTRY
C=PURPOSE   POSITION AUXILIARY STORAGE DEVICE
C=USAGE     SEE SECTION 3.3 OF DMGASP REF. MANUAL, LMSC-D626839
C
C     ++++++++++++++++++++++
      ENTRY         DM P AST
C     ++++++++++++++++++++++
C
      IDOPER =   6HDMPAST
      ASSIGN 2500 TO  LJ TASK
      GO TO 100
 2500 CONTINUE
      LCARG1 =   ARG2(1)
      LCARG2 =   ARG3(1)
      IF  (TYPEX .GE. 0)               GO TO 2800
C
C              POSITION MAGNETIC TAPE
C
C     CALL       IOM POT  (LFN, LOCDEV, LCARG1, LCARG2)
      ASTLOC(LDI) = LOCDEV
      IF (STATUS)                      6400,5000,6400
C
C               POSITION DIRECT ACCESS DEVICE
C
 2800 CONTINUE
      CALL       IOM POD   (LOCDEV, LCARG1, LCARG2, SECTOR)
      IF (LOCDEV)                      6500,2900,2900
 2900 IF (LOCDEV - LIMIT)              2950,2950,6500
 2950 ASTLOC(LDI) = LOCDEV
      GO TO 5000
C
C=ENTRY     DMRAST      DMRAST    ENTRY
C=PURPOSE   READ RECORD FROM AUXILIARY STORAGE DEVICE
C=USAGE     SEE SECTION 3.4 OF DMGASP REF. MANUAL, LMSC-D626839
C
C     ++++++++++++++++++++++
      ENTRY         DM R AST
C     ++++++++++++++++++++++
C
      IDOPER =   6HDMRAST
      ASSIGN 3000 TO  LJ TASK
      GO TO 100
 3000 CONTINUE
      SIZREC  =  ARG3(1)
      IF (SIZREC)                      6600,6600,3100
 3100 CONTINUE
      IF (SECTOR .EQ. 0)               GO TO 3200
      NEWLOC =   NEWLOC + (SIZREC-1)/SECTOR
      IF (NEWLOC - NEXT)               3200,3200,6700
 3200 CONTINUE
C
C              READ DEVICE AND CHECK STATUS WORD
C
      CALL       IOM RDR  (LFN, ARG2, SIZREC, LOCREC, TYPEX)
      IF (STATUS .GT. 1)               GO TO 7000
C
C              UPDATE DEVICE STATE AND ACCOUNTING PARAMETERS
C
      ASTCNT(5) =   ASTCNT(5) + 1
      ASTWXR(LDI) = ASTWXR(LDI) + SIZREC
      GO TO 3900
C
C=ENTRY     DMWAST      DMWAST    ENTRY
C=PURPOSE   WRITE RECORD ON AUXILIARY STORAGE DEVICE
C=USAGE     SEE SECTION 3.5 OF DMGASP REF. MANUAL, LMSC-D626839
C
C     ++++++++++++++++++++++
      ENTRY         DM W AST
C     ++++++++++++++++++++++
C
      IDOPER =   6HDMWAST
      ASSIGN 3500 TO  LJ TASK
      GO TO 100
 3500 CONTINUE
      SIZREC =   ARG3(1)
      IF (SIZREC)                      6600,6600,3550
 3550 CONTINUE
      IF (OPTXA .EQ. 3)                GO TO 6900
      IF (SECTOR .EQ. 0)               GO TO 3800
      NEWLOC =   NEWLOC + (SIZREC-1)/SECTOR
      IF (NEWLOC .GT. LIMIT)           GO TO 6800
      IF (TYPEX .EQ. 3)                GO TO 3800
C
C              IF RECORD IS TO BE WRITTEN BEYOND CURRENT EOI ON
C              MASS STORAGE DEVICE, EXTEND EOI BY DUMMY WRITES
C
      MORE =     LOCDEV - NEXT
      IF (MORE)                      3800,3700,3600
 3600 CONTINUE
      CALL       IOM XEI  (LFN, MORE)
 3700 CONTINUE
      LOCREC =   0
 3800 CONTINUE
      CALL       IOM WTR  (LFN, ARG2, SIZREC, LOCREC, TYPEX)
      IF (STATUS .GT. 1)               GO TO 7000
C
C              UPDATE DEVICE STATE AND ACCOUNTING PARAMETERS
C
      ASTCNT(4) =   ASTCNT(4) + 1
      ASTWXW(LDI) = ASTWXW(LDI) + SIZREC
 3900 CONTINUE
      ASTLOC(LDI) = NEWLOC
      ASTNXT(LDI) = MAX0 (NEWLOC,NEXT)
      ASTCNT(6) =   ASTCNT(6)   + SIZREC
      ASTCNT(7) =   ASTCNT(7)   + NWRDXF
      GO TO 5000
C
C=ENTRY     DMEAST      DMEAST    ENTRY
C=PURPOSE   WRITE EOF ON MAGNETIC TAPE
C=USAGE     SEE SECTION 3.6 OF DMGASP REF. MANUAL, LMSC-D626839
C
C     ++++++++++++++++++++++
      ENTRY         DM E AST
C     ++++++++++++++++++++++
C
      IDOPER =   6HDMEAST
      ASSIGN 4000 TO  LJ TASK
      GO TO 100
 4000 CONTINUE
C
C              WRITE TWO END-OF-FILE MARKS AND BACKSPACE TAPE
C              OVER LAST ONE
C
C     CALL       WRTEOF    (LFN)
C     CALL       WRTEOF    (LFN)
C     CALL       BSKIPF    (LFN, 1)
C
C              UPDATE DEVICE LOCATION
C
      LOCDEV =   AND (LOCDEV,770000B) + 1000B
      ASTLOC(LDI) = LOCDEV
      ASTNXT(LDI) = LOCDEV
      GO TO 5000
C
C
C=ENTRY     DMLAST      DMLAST    ENTRY
C=PURPOSE   LIST IOM INFORMATION
C=USAGE     SEE SECTION 3.7 OF DMGASP REF. MANUAL, LMSC-D626839
C
C     ++++++++++++++++++++++
      ENTRY         DM L AST
C     ++++++++++++++++++++++
C
      IF (ARG1 .NE. 0)                 CALL  IOM OSD
      IF (ARG2(1) .NE. 0)              CALL  IOM FET
      IF (ARG3(1) .NE. 0)              CALL  IOM TAB
      GO TO 5000
C
C=ENTRY     DMNAST      DMNAST    ENTRY
C=PURPOSE   CHANGE INTERNAL FILE NAME(S)
C=USAGE     SEE SECTION 5.2 OF DMGASP REF. MANUAL, LMSC-D626839
C
C     ++++++++++++++++++++++
      ENTRY         DM N AST
C     ++++++++++++++++++++++
C
      LDI =      ARG1
      ASTLFN(LDI) = LFNZF(ARG3(1).AND.MASK(42))
      NLDI =     ARG2(1) - 1
      IF (NLDI .LE. 0)                 GO TO 5000
      DO 4600  J = 1,NLDI
 4600   ASTLFN(LDI+J) =  LFNINC(ASTLFN(LDI+J-1))
C
 5000 CONTINUE
      RETURN
C
C              -----------
C              ERROR EXITS
C              -----------
C
C              ILLEGAL DEVICE INDEX
C
 6100 IOERCD =   1
      GO TO 8000
C
C              ATTEMPT TO POSITION, READ OR WRITE INACTIVE DEVICE
C
 6200 IOERCD =   2
      GO TO 8000
C
C              RESERVED ERROR CODE
C
C6300 IOERCD =   3
C     GO TO 8000
C
C              ILLEGAL TAPE POSITIONING
C
 6400 IOERCD =   4
      GO TO 8000
C
C               ILLEGAL MASS STORAGE / ECS POSITIONING
C
 6500 IOERCD =   5
      GO TO 8000
C
C              ILLEGAL RECORD SIZE
C
 6600 IOERCD =   6
      GO TO 8000
C
C              ATTEMPT TO READ MASS STORAGE AREA BEYOND EOI
C
 6700 IOERCD =   7
      GO TO 8000
C
C              DEVICE OVERFLOW ON WRITE OP
C
 6800 IOERCD =   8
      ASTLIM(LDI) = -ASTLIM(LDI)
      GO TO 8000
C
C              ATTEMPT TO WRITE ON PROTECTED FILE
C
 6900 IOERCD =   9
      GO TO 8000
C
C              MISCELLANEOUS ERROR DETECTED BY I/O HANDLER
C
 7000 IOERCD =   10
      GO TO 8000
C
C              UNABLE TO HONOR CONTROL CARD REQUEST
C
 7100 IOERCD =   11
      GO TO 8000
C
C              CONTROL CARD FORMAT ERROR
C
C7200 CONTINUE
C
C              POSTMORTEM ERROR PROCEDURE
C
 8000 CONTINUE
      IF (IOMERH - 1)                  5000,8500,8500
 8500 CONTINUE
      CALL       IOM OSD
      IF (IOERCD .GE. 10)              CALL  IOM FET
      IF (IOMERH .GE. 2)               CALL  IOM TAB
      IF (IOMERH .GE. 3)               CALL  DM ABRT
      CALL       IOFATE
      GO TO 5000
      END
*DECK       IOMCIO
* =DECK      IOMCIO      IOMCIO      ASSEMBLY
          IDENT     IOMCIO
          TITLE     COMBINED INPUT/OUTPUT FUNCTIONS
          SPACE     3
*CALL       IOMACTL
          IFEQ      OS,NOS         *
************************************                               (NOS)
*    EXTERNAL TEXT COMMON DECKS    *                               (NOS)
************************************                               (NOS)
*         LIST      X              *                               (NOS)
          XTEXT     COMCCIO        *  I/O REQUEST PROCESSOR        (NOS)
          XTEXT     COMCLFM        *  LOCAL FILE MANAGER REQUESTS  (NOS)
          XTEXT     COMCSYS        *  SYSTEM REQUEST ROUTINES      (NOS)
          ENDIF                    *
************************************
COMMON    SPACE     2
***       COMMON BLOCK DECLARATIONS
*
*
* =PROCEDURE CDMASTA     CDMERRA     CDMETSA
*CALL        CDMASTA
*CALL        CDMERRA
          USE       /CDMPAD/
BUFSIZ    SET       300B
BUFPRU    SET       BUFSIZ/100B
CMSIZ     BSSZ      1              CURRENT CM FL
BCSIZ     BSS       1              BLANK COMMON SIZE
REQCM     BSS       1              REQUESTED CM FL
LWAREC    BSS       1
PAD       BSS       0
PADDING   BSS       0
BUFFER    BSS       BUFSIZ         UTILITY BUFFER AREA
          USE       //
BCFWA     BSS       1
*
          USE       0
          SPACE     3
SYSREQ    TITLE     MISCELLANEOUS SYSTEM ACTION REQUESTS
************************************************************************
*                                                                      *
*         MISCELLANEOUS REQUESTS ISSUED TO MONITOR                     *
*                                                                      *
*         AUTHOR -  C. A. FELIPPA, NOV 1975                            *
*         UPDATE -  OCTOBER 1977  (SCOPE/NOS)                          *
*                                                                      *
************************************************************************
*                                                                      *
*         AN ENTRY POINT SUMMARY FOLLOWS.                              *
*                                                                      *
*         DMABRT    CAUSES ERROR TERMINATION OF JOB                    *
*                                                                      *
*         DMCLOK    RETURNS CURRENT READING OF SYSTEM CLOCK IN         *
*                   DISPLAY CODE FORMAT HH.MM.SS                       *
*                                                                      *
*         DMCMFL    TO ADJUST CENTRAL MEMORY FIELD LENGTH (CM FL)      *
*                   OR TO REQUEST INFORMATION ON CURRENT CM FL.        *
*                                                                      *
*         DMCMFL$   COMPASS-CALLABLE, REGISTER-RESTORING VERSION       *
*                   OF DMCMFL.                                         *
*                                                                      *
*         DMDATE    RETURNS CURRENT DATE IN DISPLAY CODE FORMAT        *
*                   MM/DD/YY  AND CLOCK READING  HH.MM.SS              *
*                                                                      *
*         DMRUNT    RETURNS CP TIME USED BY JOB.  ON SCOPE, IT         *
*                   ALSO RETURNS IO TIME AND CP TIME LIMIT.            *
*                                                                      *
************************************************************************
DMABRT    SPACE     2
***       DMABRT
*
*         ENTRY POINT TO FORCE ABNORMAL JOB TERMINATION
*
*         FORTRAN REFERENCE&
*
*         CALL      DMABRT
*
          ENTRY     DMABRT
DMABRT    BSS       1              ENTRY POINT
          ABORT                    LASCIATE OGNI SPERANZA
*                                  VOI CHE ENTRATE
DMCLOK    SPACE     2
***       DMCLOK (TIME)
*
*         ENTRY POINT TO READ SYSTEM CLOCK
*
*         CALL   DMCLOK  (TIME)
*
*         TIME      CURRENT CLOCK READING IN DISPLAY CODE FORMAT
*                   HH.MM.SS  (OR *HH.MM.SS IF ELAPSED TIME SINCE
*                   DEADSTART IS RETURNED)
*
          ENTRY     DMCLOK
DMCLOK    BSS       1
          BX5       X1             (X5) = ADDRESS(TIME)            (FTN)
          SB1       1
          CLOCK     TIMLOC         CLOCK MACRO
          SA1       TIMLOC
          BX6       X1
          SA6       X5             STORE TIME
          EQ        DMCLOK         RETURN TO CALLING PROGRAM
TIMLOC    EQU       PAD+174B
DMCMSZ    SPACE     2
***       DMCMSZ  (REQCM, CMSIZ, BCSIZ)
*
*         ENTRY POINT TO MODIFY CENTRAL MEMORY FIELD LENGTH, OR
*         TO GET INFORMATION ABOUT CM FIELD LENGTH.
*
*         FORTRAN REFERENCE -
*
*         CALL      DMCMSZ  (REQCM, CMSIZ, BCSIZ)
*
*         WHERE
*
*         REQCM     DESIRED NEW CM FL IN WORDS IF REQUESTING CORE
*                   EXPANSION OR CONTRACTION.  ZERO TO REQUEST
*                   INFORMATION ABOUT CURRENT CMSIZ/BCSIZ.
*
*         CMSIZ     CENTRAL MEMORY FL ON EXIT FROM THIS ROUTINE.
*                   IF REQCM GT 0, AND THE REQUEST IS SUCCESSFUL,
*                   CMFL IS REQCM ROUNDED UP TO NEAREST 100B MULTIPLE.
*
*         BCSIZ     BLANK COMMON SIZE ON COMPLETION OF REQUEST.
*
          ENTRY     DMCMSZ
DMCMSZ    BSS       1              ENTRY/EXIT POINT
          SB7       1              (B7) = 1
          SA2       A1+B7          (X2) = ADDRESS(CMSIZ)           (FTN)
          SA1       X1             (X1) = REQCM                    (FTN)
          MX0       -18D                                           (FTN)
          SA3       A2+B7          (X3) = ADDRESS(BCSIZ)           (FTN)
          BX6       -X0*X1         LIMIT REQCM TO 2**18-1
          LX7       X3             (X7) = ADDRESS(BCSIZ)
          BX1       X6             KEEP REQCM IN (X1)
          SA6       REQCM          SAVE REQCM ON COMMON BLOCK
          LX6       30D
          SA6       MEMREQ         SET UP REQUEST WORD
          SB6       B7+B7          (B6) = 2
          BX6       X2             (X6) = ADDRESS(CMSIZ)
          SA7       A6+B6          SAVE ADDRESS(BCSIZ)
          SA6       A6+B7          SAVE ADDRESS(CMSIZ)
          ZR        X1,DMCMSZ1     SKIP PRINT IF REQCM=0
          SA5       RFLMESS+1
          RJ        =XNCOCTL$      ENCODE REQCM INTO (X6)
          SA4       RFLMESS
          SA6       ASTMSG+2       SET ASTMSG(3)
          LX7       X5
          BX6       X4
          SA7       A6-B7          SET ASTMSG(2)
          SA6       A7-B7          SET ASTMSG(1)
          RJ        =XIOMESSG      PRINT  REQUESTED CML  MESSAGE
DMCMSZ1   BSS       0
          SB1       1
          MEMORY    CM,MEMREQ,R,,1 MEMORY MACRO
          SA1       MEMREQ         (X1) = REQUEST/REPLY WORD
          SB4       BCFWA          (B4) = FWA OF BLANK COMMON
          SA2       A1+B1          (X2) = ADDRESS(CMSIZ)
          MX0       -18D
          AX1       30D            RIGHTADJUST CURRENT FL
          SA3       A2+B1          (X3) = ADDRESS(BCSIZ)
          SB4       B1-B4
          SB6       B1+B1          (B6) = 2
          BX6       -X0*X1         (X6) = CMSIZ = CURRENT CM FL
          SX7       X6+B4          (X7) = BCSIZ = CMSIZ-BC(0)
          SA4       NFLMESS
          SA6       CMSIZ          STORE CMSIZ IN /CDMPAD/
          SA5       A4+B1
          SB4       X7             SAVE BCSIZ IN (B4) FOR PRINT
          SA7       A6+B1          STORE BCSIZ IN /CDMPAD/
          SA6       X2             STORE CMSIZ IN 2ND ARG OF DMCMSZ
          SA7       X3             STORE BCSIZ IN 3RD ARG OF DMCMSZ
          BX6       X4
          SA6       ASTMSG+1       PLACE TEXT IN ASTMSG(2)
          LX7       X5
          SA7       A6+B6          PLACE TEXT IN ASTMSG(4)
          RJ        =XNCOCTL$      OCTAL ENCODE CMSIZ IN (X6)
          SA6       A7-B1          PLACE ENCODED CMFL IN ASTMSG(3)
          SX1       B4             (X1) = BCSIZ
          RJ        =XNCOCTL$      OCTAL ENCODE BCSIZ IN (X6)
          SA6       A7+B1          PLACE ENCODED BCSIZ IN ASTMSG(5)
          RJ        =XIOMESSG      PRINT INFORMATIVE MESSAGE
          EQ        DMCMSZ         RETURN TO CALLING PROGRAM
MEMREQ    EQU       PAD+170B
RFLMESS   DIS       2,0+++      REQ CMSIZ&
NFLMESS   DIS       2,JOB CMSIZ&, BC SIZE&
DMCMSZ$   SPACE     2
***       DMCMSZ$
*
*         COMPASS-CALLABLE, REGISTER-RESTORING, GROIN-KICKING
*         VERSION OF DMCMSZ.
*
*         COMPASS REFERENCE -
*
*         (X7) =    REQCM  (SEE DMCMSZ)
*         RJ        GETCML$
*
*         REGISTER UTILIZATION -
*         ENTRY REGISTER SET ASSUMED - (B1)=(B7)=1, (B6)=2
*         X1,X6,A1,A2,A3,A4,A5,A6,A7    DESTROYED
*         X0,X2,X3,X4,X5,B2,B3,B4,B5    PRESERVED
*         (B1),(B6),(B7) RESTORED TO 1,2,1, RESPECTIVELY.
*         (X1) = CMSIZ = CURRENT CM FL ON RETURN FROM DMCMSZ$.
*
          ENTRY     DMCMSZ$
DMCMSZ$   BSSZ      1
          SA7       REQCM          STORE (X7) IN REQCM WORD
          SB7       1
          LX6       X5
          BX7       X4
          SA6       SAVE+1         (X5) TO SAVE+1
          SB6       B7+B7
          SA7       A6+B7          (X4) TO SAVE+2
          BX6       X3
          LX7       X2
          SA6       A6+B6          (X3) TO SAVE+3
          BX6       X0
          SA7       A7+B6          (X2) TO SAVE+4
          SA6       A6+B6          (X0) TO SAVE+5
          SX6       B5
          SX7       B4
          SA6       A6+B7          (B5) TO SAVE+6
          SX6       B3
          SA7       A6+B7          (B4) TO SAVE+7
          SX7       B2
          SA6       A6+B6          (B3) TO SAVE+8
          SA7       A7+B6          (B2) TO SAVE+9
          SA1       REQCMADS       (A1) POINTS TO ARG ADS LIST     (FTN)
          RJ        DMCMSZ         EXECUTE DMCMSZ
          SB7       1              RESTORE (B7) = 1
          SA1       SAVE+9
          SB6       B7+B7          RESTORE (B6) = 2
          SA2       A1-B7
          SA3       A1-B6
          SA4       A2-B6
          SB2       X1             RESTORE (B2)
          SA1       A4-B7
          SB3       X2             RESTORE (B3)
          SA2       A1-B7          RESTORE (X2)
          SB4       X3             RESTORE (B4)
          SA3       A2-B7          RESTORE (X3)
          SB5       X4             RESTORE (B5)
          SA4       A3-B7          RESTORE (X4)
          BX0       X1             RESTORE (X0)
          SA1       CMSIZ          (X1) = CMSIZ  ON RETURN
          SA5       A4-B7          RESTORE (X5)
          SB1       B7             RESTORE (B1) = 1
          EQ        DMCMSZ$        RETURN
SAVE      EQU       PADDING+100B
REQCMADS  VFD       42/0,18/REQCM  ADDRESS(REQCM)
CMSIZADS  VFD       42/0,18/CMSIZ  ADDRESS(CMSIZ)
BCSIZADS  VFD       42/0,18/BCSIZ  ADDRESS(BCSIZ)
DMCONV    SPACE     2
***       DMCONV
*
          ENTRY     DMCONV
DMCONV    BSS       1
          SX6       1
          SA6       DMERCM
          EQ        DMCONV
*
DMDATE    SPACE     2
***       DMDATE  (DATIM)
*
*         ENTRY POINT TO RETRIEVE CURRENT DATE AND TIME
*
*         CALL   DMDATE  (DATIM)
*
*         DATIM     A TWO-WORD ARRAY. CURRENT DATE WILL BE
*                   RETURNED IN DATIM(1) IN DISPLAY CODE FORMAT
*                   MMDDYY LEFTJUSTIFIED WITH BLANK FILL.
*                   THE CURRENT TIME WILL BE STORED IN DATIM(2),
*                   IN FORMAT HHMMSS ALSO LEFTJUSTIFIED BLANKFILLED.
*
          ENTRY     DMDATE
DMDATE    BSSZ      1              ENTRY/EXIT POINT
          BX5       X1             (X5) = ADDRESS(DATIM)           (FTN)
          SB1       1              (B1) = 1
          DATE      TIMLOC         DATE MACRO
          CLOCK     TIMLOC+1       CLOCK MACRO
          SA1       TIMLOC
          SA4       =4R
          MX0       12
          SB2       6
          LX1       6
          LX2       B2,X1
          BX1       X0*X1
          LX3       B2,X2
          LX0       48
          BX2       X0*X2
          LX0       48
          BX3       X0*X3
          BX6       X1+X2
          SA1       A1+B1
          BX6       X6+X3
          BX6       X6+X4
          MX0       12
          SA6       X5             STORE DATIM(1)
          LX1       6
          LX2       B2,X1
          LX3       B2,X2
          BX1       X0*X1
          LX0       48
          BX2       X0*X2
          LX0       48
          BX3       X0*X3
          BX7       X1+X2
          BX7       X7+X3
          BX7       X7+X4
          SA7       X5+B1          STORE DATIM(2)
          EQ        DMDATE         RETURN TO CALLING PROGRAM
DMFATE    SPACE     2
***       DMFATE
*
          ENTRY     DMFATE
DMFATE    BSS       1
          SA2       DMSERRJ
          SA1       DMSERRL                                        (FTN)
          MX0       -18
          BX2       -X0*X2
DMSERRJ   ZR        X2,DMABRT      DIRECT ABORT IF NO USER-SPEC ROUTINE
          RJ        0              TRANSFER TO DMTERM-SPECIFIED ENTRY
DMSERRL   VFD       42/0,18/=3HDMS
          VFD       42/0,18/DMERCD
DMHAST    SPACE     2
***       DMHAST  (IERH, UPGERR, 0)
*
          ENTRY     DMHAST
DMHAST    BSS       1
          SA2       A1+1                                           (FTN)
          SA1       X1             (X1) = IERH                     (FTN)
          MX0       -18
          SA5       IOMERRJ
          BX7       X1
          SA3       X2             (X3) = VALUE(UPGERR)
          BX6       X0*X5          MASK OUT RJ ADDRESS FIELD
          SA7       IOMERH         SET IOM ERROR HANDLING FLAG
          SA6       A5
          ZR        X3,DMHAST      EXIT IF ZERO SECOND ARGUMENT
          BX2       -X0*X2
          BX6       X6+X2
          SA6       A6             STORE TRANSFER TO UPGERR
          EQ        DMHAST
*
DMRUNT    SPACE     2
***       DMRUNT  (CPTIME, IOTIME, CPTLIM)
*
*         ENTRY POINT TO OBTAIN PROGRAM TIMING INFORMATION
*
*         CALL   DMRUNT  (CPTIME, IOTIME, TIMLIM)
*
*         CPTIME    ELAPSED CP TIME IN F.P. SECONDS
*
*         IOTIME    ELAPSED I/O TIME IN F.P. SECONDS
*
*         TIMLIM    JOB CP TIME LIMIT IN F.P. SECONDS
*
          ENTRY     DMRUNT
DMRUNT    BSSZ      1
          SB7       1
          SA2       A1+B7                                          (FTN)
          SB1       X1                                             (FTN)
          SA3       A2+B7                                          (FTN)
          SB2       X2                                             (FTN)
          SB3       X3                                             (FTN)
          MX6       0
          SB1       B7
          SA6       TIMLOC+1
          TIME      TIMLOC         GET TIME LIMIT, AND CP TIME
          IFEQ      OS,SCOPE
          IOTIME    TIMLOC+1       GET IO TIME                   (SCOPE)
          ENDIF
          SA1       TIMLOC         (X1) = 24/CPTLIM,36/CPTIME(SEC,MSEC)
          MX0       24D
          SA2       A1+B7          (X2) = 24/IOTLIM,36/IOTIME(SEC,MSEC)
          BX6       X0*X1          (X6) = ISOLATED TIMLIM FIELD
          BX1       -X0*X1         CLEAR CPTLIM FIELD
          LX6       24D
          BX2       -X0*X2         CLEAR IOTLIM FIELD
          MX0       -12D
          PX6       X6
          NX6       X6
          BX3       -X0*X1         (X3) = CPTIME MSEC (INTEGER)
          BX4       -X0*X2         (X4) = IOTIME MSEC (INTEGER)
          SA6       B3             STORE CP TIME LIMTI
          SX5       1000D
          AX1       12D            RIGHTJUSTIFY CPTIME SECS
          AX2       12D            RIGHTJUSTIFY IOTIME SECS
          DX1       X1*X5          (X1) = CPTIME SECS TO MILLISEC
          DX2       X2*X5          (X1) = IOTIME SECS TO MILLISEC
          SA5      =0.001          (X5) = MSEC TO SEC CONV FACTOR
          IX1       X1+X3
          IX2       X2+X4
          PX1       X1
          PX2       X2
          NX1       X1
          NX2       X2
          RX6       X1*X5
          RX7       X2*X5
          SA6       B1             STORE ELAPSED CP TIME (F.P. SECS)
          SA7       B2             STORE ELAPSED IO TIME (F.P. SECS)
          EQ        DMRUNT         RETURN TO CALLING PROGRAM
DMTERM    SPACE     2
*
***       DMTERM  (UPGERR)
*
          ENTRY     DMTERM
DMTERM    BSS       1
          SA2       DMSERRJ
          MX0       -18
          BX2       X0*X2
          BX6       X1+X2
          SA6       A2
          EQ        DMTERM
DMUSER    SPACE     2
***       DMUSER (NAME)
*
          ENTRY     DMUSER
DMUSER    BSS       1
          SA1       X1                                             (FTN)
          BX6       X1
          SA6       TRSTAK
          EQ        DMUSER
IOFATE    SPACE     2
***       IOFATE
*
          ENTRY     IOFATE
IOFATE    BSS       1
          SA2       IOMERRJ
          SA1       IOMERRL                                        (FTN)
          MX0       -18
          BX2       -X0*X2
IOMERRJ   ZR        X2,IOFATE      RETURN IF NO USER-SPECIFIED ROUTINE
          RJ        0              ELSE JUMP TO IT
          EQ        IOFATE
IOMERRL   VFD       42/0,18/=3HIOM
          VFD       42/0,18/DMERCD
*
          TITLE     PROCEDURES FOR PHYSICAL DATA TRANSMISSION
************************************************************************
*         PROCEDURES INVOLVING ACTUAL DATA TRANSFER BETWEEN            *
*         CENTRAL MEMORY AND AUXILIARY STORAGE                         *
*                                                                      *
*         AUTHOR -  C. A. FELIPPA, SEPT. 1975                          *
*         UPDATE -  NOVEMBER 1977                                      *
*                                                                      *
************************************************************************
*                                                                      *
*         ENTRY POINT SUMMARY -                                        *
*                                                                      *
*         IOMEOF    WRITES AN END-OF-FILE MARK                         *
*                                                                      *
*         IOMPRU    GET MASS STORAGE FILE SIZE (IN PRUS)               *
*                                                                      *
*         IOMRDR    TRANSFERS A DATA BLOCK (RECORD) FROM AN AUX        *
*                   STORAGE DEVICE CHARACTERIZED BY A DMGASP DEVICE    *
*                   TYPE INDEX, TO MAIN STORAGE.  (ALT ENTRY RDMS      *
*                   ASSUMES SECTOR-ADDRESSABLE MASS STORAGE).          *
*                                                                      *
*         IOMWTR    TRANSFERS A DATA BLOCK (RECORD) FROM MAIN          *
*                   STORAGE TO AN AUX STORAGE DEVICE CHARACTERIZED     *
*                   A DMGASP DEVICE TYPE INDEX.  (ALT ENTRY WTMS       *
*                   ASSUMES SECTOR-ADDRESSABLE MASS STORAGE.)          *
*                                                                      *
*         IOMXEI    EXTENDS EOI BY WRITING DUMMY PRUS                  *
*                                                                      *
************************************************************************
IOMEOF    SPACE     2
***       IOMEOF  (LFN)
*
*         WRITE AN END-OF-FILE MARK AT CURRENT DEVICE POSITION
*
*         FORTRAN REFERENCE -
*
*         CALL   IOMEOF (LFN)
*
*         WHERE
*
*         LFN       LOGICAL FILENAME
*
          ENTRY     IOMEOF
IOMEOF    BSSZ      1
          SX2       0104B          R-BIT=0,EP-BIT=1,XP-BIT=0,FETL=4
          MX4       0
          SX3       X2             DUMMY BUFFER ADDRESS
          MX5       0
          SX6       B0
          RJ        =XFETSET$      ESTABLISH FET
          WRITEF    FET,R          WRITE W/EOF MACRO
          RJ        =XFETRET$      GET RET/AT CODES
          EQ        IOMEOF         RETURN TO CALLING PROGRAM
IOMPRU    SPACE     2
***       IOMPRU    (LFN)
*
*         OBTAIN LENGTH OF MASS STORAGE FILE IN PRUS
*
*         FORTRAN REFERENCE -
*
*         NPRU =    IOMPRU (LFN)
*
*         WHERE
*
*         LFN       LOGICAL FILENAME
*
*         IOMPRU    CURRENT FILE SIZE IN PRUS
*
*         REMARK -  THE NOS PRU COUNT (AS RETURNED BY THE LENGTH CC)
*         IS ALWAYS ONE MORE THAN THE SCOPE COUNT (AS RETURNED BY
*         THE STATUS MACRO). NO REASONS FOR THIS DISCREPANCY ARE
*         KNOWN (WHEN DOES A CDC O/S EVER MAKES SENSE, ANYWAY).
*         THIS FUNCTION CORRECTS THE NOS COUNT BY SUBSTRACTING 1.
*
          ENTRY     IOMPRU
IOMPRU    BSS       1              ENTRY/EXIT
          SB7       1              (B7) = 1
          IFEQ      OS,SCOPE
          MX6       1                                            (SCOPE)
          SA1       X1             (X1) = LFN                    (SCOPE)
          LX6       38D            (X6) = LIST HEADER = 24/2,36/0(SCOPE)
          MX0       42D                                          (SCOPE)
          SA6       FET            PUT LIST HEADER IN FET(1)     (SCOPE)
          BX7       X0*X1                                        (SCOPE)
          MX6       0                                            (SCOPE)
          SA7       A6+B7          STORE LFN IN FET(2)           (SCOPE)
          SA6       A7+B7          CLEAR FET(3)                  (SCOPE)
          STATUS    FET,3,R        ISSUE STATUS REQUEST          (SCOPE)
          SA1       FET+2          (X1) = WORD WITH PRU COUNT    (SCOPE)
          MX0       -24D                                         (SCOPE)
          BX6       -X0*X1         MASK OUT PRU COUNT FIELD      (SCOPE)
          ELSE
          MX4       0                                              (NOS)
          SX2       1002B                                          (NOS)
          SX3       PAD                                            (NOS)
          SX5       B0                                             (NOS)
          MX6       0                                              (NOS)
          RJ        =XFETSET$      ESTABLISH A FET                 (NOS)
          SKIPEI    FET,R          POSITION FILE TO EOI            (NOS)
          STATUS    FET,P          GET FNT/FST ENTRIES             (NOS)
          SA1       FET+6          (X1) = FET(7) = FST ENTRY       (NOS)
          MX0       -12D                                           (NOS)
          AX1       12D            RIGHTJUSTIFY SECTOR COUNT FLD   (NOS)
          BX6       -X0*X1         (X6) = CURRENT SECTOR NO.       (NOS)
          AX1       12D            RIGHJUSTIFY CURRENT TRACK FLD   (NOS)
          BX2       -X0*X1         (X2) = CURRENT TRACK NO.        (NOS)
          AX1       12D            RIGHTJUSTIFY FIRST-TRACK FIELD  (NOS)
          SX3       214D           (X3) = SECTORS PER TRACK        (NOS)
          BX1       -X0*X1         (X1) = FIRST TRACK VALUE        (NOS)
          IX2       X2-X1          (X2) = TRACK COUNT              (NOS)
          SX4       B1             (X4) = 1                        (NOS)
          DX2       X2*X3          CONVERT TRACK DIFF TO SECTORS   (NOS)
          IX6       X2+X6          (X6) = SECTORS (PRU) COUNT      (NOS)
          IX6       X6-X4          MAKE COUNT SCOPE COMPATIBLE     (NOS)
          PL        X6,IOMPRU                                      (NOS)
          MX6       0              IF COUNT NEGATIVE, SET (X6) = 0 (NOS)
          ENDIF
          EQ        IOMPRU         RETURN
*
IOMRDR    SPACE     2
***       IOMRDR    (LFN, A, N, LOCR, TYPEX)
***       RD MS     (LFN, A, N, LOCR)
*
*         ENTRY TO READ A RECORD FROM AUXILIARY STORAGE
*
*         FORTRAN REFERENCE -
*
*         CALL   IOMRDR  (LFN, A, N, LOCR, TYPEX)
*
*
*         WHERE THE FUNCTION OF THE ARGUMENTS IS IDENTICAL TO
*         THOSE OF IOMWTR (SEE BELOW)
*
          ENTRY     IOMRDR
*         ENTRY     IOMRDR,RDMS
RDMS      BSS       1              STAGS-COMPATIBLE ENTRY POINY
          SA5       RDMS           FETCH RETURN INSTRUCTION
          SB7       1
          BX7       X5
          SA3       A1+B7          (X3) = ADDRESS(A)               (FTN)
          SA4       A3+B7          (X4) = ADDRESS(N)               (FTN)
          SA2       A4+B7          (X2) = ADDRESS(LOCR)            (FTN)
          SA4       X4             (X4) = N                        (FTN)
          SB4       X2             (B4) = ADDRESS(LOCR)            (FTN)
          SA7       IOMRDR         STORE RETURN INSTR
          NG        X4,IOMRDR      EXIT IF N LT 0
          EQ        RDSAMS         TO SECTOR-ADDRESSABLE MS SECTION
*
IOMRDR    BSSZ      1              MAIN ENTRY POINT TO READ A RECORD
          SB7       1              (B7) = 1
          SB6       B7+B7          (B6) = 2
          SA4       A1+B6          (X4) = ADDRESS(N)               (FTN)
          SA3       A1+B7          (X3) = ADDRESS(A)               (FTN)
          SA5       A4+B6          (X5) = ADDRESS(TYPEX)           (FTN)
          SA2       A4+B7          (X2) = ADDRESS(LOCR)            (FTN)
          SA4       X4             (X4) = N                        (FTN)
          SA5       X5             (X5) = TYPEX                    (FTN)
          SB4       X2             (B4) = ADDRESS(LOCR)            (FTN)
          SB5       X5             (B5) = TYPEX
          NG        X4,IOMRDR      EXIT IF N LT 0
          GT        B5,B6,RDECS    TO ECS-READ SECTION IF TYPEX = 3
          EQ        B5,B6,RDWAMS   TO WAMS SECTION IF TYPEX = 2
          LT        B5,B0,RDTAPE   TO TAPE-READ SECTION IF TYPEX LT 0
*
*         READ RECORD FROM SECTOR-ADDRESSABLE MASS STORAGE
*
RDSAMS    BSS       0
          SX5       X4+77B         (X5) = N + (64-1), (64=PRU SIZE)
          SX2       1104B          R-BIT=1,EP-BIT=1,XP-BIT=0,FETL=4
          AX5       6              (X5) = (N+63)/64
          SX6       B7             LIMIT = ADS(BUFFER)+NWXF+1
          LX5       6              (X5) = NWXF = 64*((N+63)/64)
          IX0       X5-X4          (X0) = NWXF-N = NWPAD
          BX4       X5             (X4) = NWXF FOR FET ASSEMBLY
          MX5       0              (X5) = 0  TO MARK READ CONDITION
          IX7       X3+X4          (X7) = ADDRESS(A)+NWXF
          SB2       X0             (B2) = NWPAD
          SB5       X7             (B5) = ADDRESS(A(NWXF+1))
          RJ        =XFETSET$      ESTABLISH FET
          SA4       B4             (X4) = LOCR = PRU ORDINAL
          SA1       CMSIZ          (X1) = CURRENT CM FL
          BX6       X4             (X6) = LOCR
          SA6       FET+6          PRU ORDINAL TO FET(7)
          NZ        X1,RDSAMS1     SKIP IF CMSIZ CONTAINS NZ VALUE
          MX7       0              ELSE CLEAR (X7) TO FLAG CMSIZ REQUEST
          RJ        =XDMCMSZ$      AND OBTAIN CURRENT JOB SIZE
RDSAMS1   BSS       0
          EQ        B2,RDSAMS4     OMIT PADDING PROCESSING IF NWPAD=0
          SB3       X1             (B3) = CMSIZ
          SX7       B5             (X7) = ADDRESS(A(NWXF+1))
          GE        B3,B5,RDSAMS2  OMIT FL EXPANSION IF FL GE IN
          RJ        =XDMCMSZ$      ELSE EXPAND CM TO (X7) WORDS
RDSAMS2   BSS       0
          SA7       PADDING-1      (A7) POINTS TO PADDING(0)
          SA2       B5             (A2) POINTS TO A(NWXF+1)
          SB3       B0             INITIALIZE WORD XFER COUNTER
RDSAMS3   BSS       0
           SA2       A2-B7         (X2) = A(NWXF+1-J)
           SB3       B3+B7         INCREMENT COUNTER
           BX7       X2
           SA7       A7+B7         STORE IN PADDING(J)
           LT        B3,B2,RDSAMS3 CYCLE
          SA5       A7             (A5) = EXIT (A7) FOR RESTORE LOOP
          SX5       A2             (X5) = EXIT (A2) FOR RESTORE LOOP
RDSAMS4   BSS       0
          IFEQ      OS,NOS
          SX0       B2             SAVE (B2) = NWPAD IN (X0)       (NOS)
          ENDIF
          READNS    FET,R          READ IGNORING EOR
          IFEQ      OS,NOS
          SB2       X0             RESTORE (B2) = NWPAD            (NOS)
          ENDIF
          RJ        =XFETRET$      GET RETURN DATA FROM FET
          EQ        B2,IOMRDR      SKIP PAD-RESTORE IF NWPAD = 0
          SA3       A5             (X3) = LAST WORD SAVED IN PADDING
          SB2       B2-B7
          BX6       X3
          SA6       X5             RESTORE A(N+1)
          LE        B2,IOMRDR      EXIT IF NWPAD = 1
RDSAMS6   BSS       0
           SA3       A3-B7         (X3) = NEXT SAVED WORD
           SB2       B2-B7         DECREMENT COUNTER
           BX6       X3
           SA6       A6+B7         RESTORE A(N+J)
           GT        B2,RDSAMS6    CYCLE UNTIL (B2) = 0
          EQ        IOMRDR         RETURN TO CALLING PROGRAM
*
*         READ RECORD FROM (SIMULATED) WORD-ADDRESSABLE
*         MASS STORAGE DEVICE (NOT YET IMPLEMENTED)
*
RDWAMS    BSS       0
          EQ        WRWAMS         ISSUE DF MESSAGE AND ABORT
*
*         READ RECORD FROM TAPE
*
RDTAPE    BSS       0
          SX2       0114B          R-BIT=0,EP-BIT=1,XP-BIT=1,FETL=4
          SX6       1000B          LIMIT = ADS(BUFFER)+N+1000B
          MX5       0              MARK READ CONDITION
          RJ        =XFETSET$      ESTABLISH FET
          READ      FET,R          STANDARD READ W/RECALL
          RJ        =XFETRET$      GET RETURN DATA FROM FET
          EQ        IOMRDR         RETURN TO CALLING PROGRAM
*
*         READ FROM EXTENDED CORE STORAGE
*
RDECS     BSS       0
          SA2       B4             (X2) = LOCR
          SB1       A0
          SA0       X3             (A0) = ADDRESS(A)
          SB3       X4             (B3) = N
          BX0       X2             (X0) = ECS SOURCE ADDRESS
          SX6       B3             (X6) = N
          RE        B3             XMIT BLOCK
          SA6       NWRDXF         SET NWRDXF
          SA0       B1             RESTORE (A0)
          EQ        IOMRDR         RETURN TO CALLING PROGRAM
*
IOMWTR    SPACE     2
***       IOMWTR    (LFN, A, N, LOCR, TYPEX)
***       WTMS      (LFN, A, N, LOCR)
*
*         ENTRY TO WRITE A RECORD ON AUXILIARY STORAGE
*
*         FORTRAN REFERENCE -
*
*         CALL   IOMWTR  (LFN, A, N, LOCR, TYPEX)
*         CALL   WT MS   (LFN, A, N, LOCR)
*
*         WHERE
*
*         LFN       LOGICAL FILENAME IF AUXILIARY STORAGE MEDIUM
*                   IS MASS STORAGE OR MAGNETIC TAPE.  IGNORED IF
*                   RECORD IS TO BE WRITTEN ON ECS (LCM).
*
*         A         FWA OF SOURCE ARRAY IN PRIMARY MEMORY
*
*         N         NUMBER OF WORDS TO TRANSMIT. N=0 IS ADMISSIBLE.
*
*         LOCR      RECORD ADDRESS ARGUMENT.  SIGNIFICANCE DEPENDS
*                   ON EQUIPMENT TYPE.
*
*                   SECTOR-ADDRESSABLE MASS STORAGE (TYPEX=0,1)
*                     LOCR = 0   WRITE NEW RECORD AT EOI.  UPON A
*                     SUCCESSFUL WRITE, THE SYSTEM RETURNS THE  REL
*                     SECTOR ADDRESS (RSA) OF THE RECORD IN LOCR.
*                     LOCR GT 0.  SPECIFIES RECORD REWRITE AT
*                     RELATIVE SECTOR ADDRESS (RSA) IN LOCR.
*
*                   WORD-ADDRESSABLE MASS STORAGE (TYPEX=2)  THIS
*                   MODE IS NOT PRESENTLY IMPLEMENTED.
*
*                   MAGNETIC TAPE (TYPEX LT 0).  LOCR IS IGNORED
*                   AND RECORD XMISSION PROCEEDS AT CURRENT LOCATION.
*
*                   ECS/LCM (TYPEX=3). LOCR = FWA OF DESTINATION AREA.
*
*         TYPEX     DMGASP DEVICE TYPE INDEX (SEE DMGASP MANUAL)
*
*         NOTES -
*         1.  ENTRY WTMS (PROVIDED FOR STAGS COMPATIBILITY) ASSUMES
*             TYPEX = 0, I.E. SECTOR-ADDRESSABLE MASS STORAGE.
*
*         2.  NO END-OF-RECORD IS MARKED WHEN WRITING ON A RANDOM
*             ACCESS DEVICE (TYPEX GE 0).  TAPE RECORDS ARE TERMINATED
*             BY AN EOR MARK.
*             (THIS M.O. SIMPLIFIES UNIVAC I/O SIMULATION)
*
          ENTRY     IOMWTR
*         ENTRY     IOMWTR,WTMS
WTMS      BSS       1              STAGS-COMPATIBLE ENTRY
          SA5       WTMS           FETCH RETURN RJ INSTRUCTION
          SB7       1              (B7) = 1
          BX7       X5             (X7) = RET INSTR
          SA3       A1+B7          (X3) = ADDRESS(A)               (FTN)
          SA4       A3+B7          (X4) = ADDRESS(N)               (FTN)
          SA2       A4+B7          (X2) = ADDRESS(LOCR)            (FTN)
          SA4       X4             (X4) = N                        (FTN)
          SB4       X2             (B4) = ADDRESS(LOCR)            (FTN)
          SA7       IOMWTR         STORE RETURN INSTR
          NG        X4,IOMWTR      EXIT IF N LT 0
          EQ        WRSAMS         TO SECTOR-ADDRESSABLE MS SECTION
*
IOMWTR    BSSZ      1              MAIN ENTRY POINT TO WRITE A RECORD
          SB7       1              (B7) = 1
          SB6       B7+B7          (B6) = 2
          SA4       A1+B6          (X4) = ADDRESS(N)               (FTN)
          SA3       A1+B7          (X3) = ADDRESS(A)               (FTN)
          SA5       A4+B6          (X5) = ADDRESS(TYPEX)           (FTN)
          SA2       A4+B7          (X2) = ADDRESS(LOCR)            (FTN)
          SA4       X4             (X4) = N                        (FTN)
          SA5       X5             (X5) = TYPEX                    (FTN)
          SB4       X2             (B4) = ADDRESS(LOCR)            (FTN)
          SB5       X5             (B5) = TYPEX
          NG        X4,IOMWTR      EXIT IF N LT 0
          GT        B5,B6,WRECS    TO ECS-WRITE SECTION IF TYPEX = 3
          EQ        B5,B6,WRWAMS   TO WAMS SECTION IF TYPEX = 2
          LT        B5,B0,WRTAPE   TO TAPE-WRITE SECTION IF TYPEX LT 0
*
*         WRITE RECORD ON SECTOR-ADDRESSABLE MASS STORAGE
*
WRSAMS    BSS       0
          SX5       X4+77B         (X5) = N + (PRUSIZ-1)
          SX2       1104B          R-BIT=1,EP-BIT=1,XP-BIT=0,FETL=4
          AX5       6              (X5) = (N+63)/64
          SX6       B7             MARK  LIMIT = ADS(BUFFER)+NWXF+1
          LX5       6              (X5) = NWXF = 64*((N+63)/64)
          IX0       X5-X4          (X0) = NWXF-N = NWPAD
          BX4       X5             (X4) = NWXF FOR FET ASSEMBLY
          IX7       X3+X5          (X7) = ADDRESS(A)+NWXF
          SB2       X0             (B2) = NWPAD
          SB5       X7             (B5) = ADDRESS(A(NWXF+1))
          RJ        =XFETSET$      ESTABLISH FET
          SA4       B4             (X4) = LOCR
          SX0       B7             (X0) = 1
          SX6       B4             (X6) = ADDRESS(LOCR)
          MX7       0              (X7) = 0 TO FLAG DMCMSZ REQUEST
          ZR        X4,WRSAMS1     TEST FOR LOCR = 0 (WRITE AT EOI)
          IFEQ      OS,SCOPE
          BX6       X4             (X6) = LOCR                   (SCOPE)
          ELSE
          LX0       29D            (X0) = 30/0,1/1,29/0            (NOS)
          BX6       X4+X0          (X6) = LOCR + REWRITE BIT       (NOS)
          ENDIF
WRSAMS1   BSS       0
          SA1       CMSIZ          (X1) = CURRENT CM FL
          SA6       FET+6          ADS(LOCR)/LOCR TO FET(7)
          NZ        X1,WRSAMS2
          RJ        =XDMCMSZ$      GET CURRENT CM SIZE
WRSAMS2   BSS       0
          EQ        B2,WRSAMS5     OMIT PADDING PROCESSING IF NWPAD=0
          SB3       X1             (B3) = CMSIZ
          SX7       B5             (X7) = ADDRESS(A(NWXF+1))
          GE        B3,B5,WRSAMS3  OMIT FL EXPANSION IF FL GE IN
          RJ        =XDMCMSZ$      ELSE EXPAND CM FL TO (X7) WORDS
WRSAMS3   BSS       0
WRSAMS5   BSS       0
          NZ        X4,WRSAMS6     BRANCH ON LOCR = ZR/NZ
          WRITE     FET,R          WRITE MACRO
          EQ        WRSAMS7
WRSAMS6   BSS       0
          REWRITE   FET,R          REWRITE MACRO
WRSAMS7   BSS       0
          RJ        =XFETRET$      OBTAIN FET STATUS DATA
          SA2       EOICOD         (X2) = EOI CODE
          SA3       OUTMIN         (X3) = OUT-IN
          MX6       42D            (X6) = FILENAME MASK
          SB5       X2             (B5) = EOI CODE
          ZR        X3,WRSAMS8     IF IN=OUT, WRITING IS COMPLETE
          SA1       FET            (X1) = FET HEADER WORD
          NE        B5,B7,WRSAMS8  TEST FOR TRUNCATION ON HITTING EOI
          SX2       B6+B7          (X2) = 3
          BX6       X6*X1          MASK OUT LFN IN (X6)
          BX6       X6+X2          SET INTERLOCK/BINARY-MODE BITS
          MX7       0
          SA6       A1             RESTORE FET(1) TO VIRGIN CONDITION
          SA7       NWRDXF         RESET NWRDXF TO ZERO
          WRITE     FET,R          ISSUE FINAL WRITE TO MOVE EOI
          RJ        =XFETRET$      GET RETURN PARAMETERS FROM FET
WRSAMS8   BSS       0
          EQ        IOMWTR         RETURN TO CALLING PROGRAM
*
*         WRITE ON WORD-ADDRESSABLE MASS STORAGE (NOT IMPLEMENTED)
*
WRWAMS    BSS       0
          MESSAGE   WAMSG,,R
          ABORT
WAMSG     DIS       4,WORD-ADDRESSABLE MODE NOT AVAILABLE
          BSSZ      1
*
*         WRITE RECORD ON TAPE
*
WRTAPE    BSS       0
          SX2       0114B          R-BIT=0,EP-BIT=1,XP-BIT=1,FETL=4
          SX6       1000B          LIMIT = ADS(BUFFER)+N+1000B
          SB3       X4             (B3) = N
          BX5       X4             X5 = N (WRITE CONDITION)
          RJ        =XFETSET$      ESTABLISH FET
          IFEQ      OS,SCOPE
          WRITER    FET,,R         WRITE W/EOR AND RECALL        (SCOPE)
          ELSE
          WRITER    FET,R          WRITE W/EOR AND RECALL          (NOS)
          ENDIF
          RJ        =XFETRET$      GET RETURN PARAMETERS FROM FET
          EQ        IOMWTR         RETURN TO CALLING PROGRAM
*
*         WRITE ON EXTENDED CORE (LARGE MEMMORY)
*
WRECS     BSS       0
          SA2       B4             (X2) = LOCR
          SB1       A0
          SB3       X4             (B3) = N
          SA0       X3             (A0) = ADDRESS(A)
          SX6       B3             (X6) = N
          BX0       X2             (X0) = ECS DESTINATION ADDRESS
          WE        B3             XMIT N-WORD BLOCK (B3) = N
          SA6       NWRDXF         SET NWRDXF
          SA0       B1             RESTORE (A0)
          EQ        IOMWTR         RETURN
*
IOMXEI    SPACE     2
***       IOMXEI    (LFN, NPRUS)
*
*         EXTEND EOI OF MASS STORAGE FILE BY WRITING A SPECIFIED
*         NUMBER OF DUMMY (ZERO FILLED) PHYSICAL RECORD UNITS (PRUS).
*         THIS IS NEEDED FOR UNIVAC SIMULATION ON THE CDC.
*
*         FORTRAN REFERENCE -
*
*         CALL      IOMXEI (LFN, NPRUS)
*
*         WHERE
*
*         LFN       LOGICAL FILE NAME
*
*         NPRUS     NO. OF PRUS TO BE WRITTEN (MAX 2**17)
*
*
*
          ENTRY     IOMXEI
IOMXEI    BSS       1              ENTRY/EXIT
          SB7       1              (B7) = 1
          SA5       A1+B7          (X5) = ADDRESS(NPRUS)           (FTN)
          SA5       X5             (X5) = NPRUS                    (FTN)
          BX6       X1
          SA6       LFNADS         SAVE ADDRESS(LFN)
          BX7       X5
          SA7       A6+B7          SAVE NPRUS
          BX1       X5
          RJ        =XNCOCTL$      ENCODE NPRUS IN (X6)
          SA2       XEIMESG
          SA6       ASTMSG+3
          SA3       A2+B7
          SA4       A3+B7
          LX7       X3
          BX6       X4
          SA7       A6-B7
          SA6       A6+B7
          BX7       X2
          SA7       A7-B7
          RJ        =XIOMESSG      PRINT MESSAGE
          SA1       LFNADS         RESTORE (X1) = LFN ADDRESS
          SA5       PRUXEI         RESTORE (X5) = NPRUS
          SX2       1104B
          SX3       BUFFER         (X3) = ADDRESS(BUFFER)
          SX4       BUFSIZ         (X4) = BUFFER SIZE (WORDS)
          BX5       X4             (X5) = (X4) FOR WRITE MODE
          MX6       0
          SB4       X4             (B4) = BUFSIZ
          RJ        =XFETSET$      ESTABLISH FET
          MX6       0              CLEAR (X6)
          SB2       B7             INITIALIZE COUNTER (B2)=1
          SA6       BUFFER         INITIALIZE (A6)
XTEOI1     BSS       0
           SB2       B2+B7         COUNT
           SA6       A6+B7         CLEAR BUFFER WORD
           LT        B2,B4,XTEOI1  CYCLE UNTIL BUFFER IS CLEARED
*
XTEOI2     BSS       0
           SA5       PRUXEI        (X5) = REMAINING PRUS TO WRITE
           SA1       FET           (X1) = FET HEADER
           MX0       44D
           SB3       BUFPRU
           SB5       X5            (B5) = REMAINING PRUS
           LX0       2             (X0) = MASK FOR LFN AND MODE/ITLOCK
           SX6       B5-B3         DECREMENT REM.PRU COUNTER
           BX7       X0*X1         (X7) = FET HEADER WORD
           SA6       PRUXEI
           SA7       A1            STORE FET HEADER
           SX6       B3            ASSUME FULL BUFFER WRITE
           SX7       BUFFER-1      (X7) = ADDRESS(BUFFER-1)
           LT        B5,IOMXEI     EXIT IF (B5) LE 0
           GE        B5,B3,XTEOI3  TEST FOR LAST PARTIAL WRITE
           SX6       B5
XTEOI3     BSS       0
           SA7       FET+6         ADDRESS(BUFFER-1) TO FET(7)
           SX7       X7+B7         (X7) = ADDRESS(BUFFER)
           LX6       6             CONVERT PRUS TO WORDS
           SA6       NWXWRT        TO GET CORRECT NWRDXF
           SA7       FET+3         RESET (OUT) = ADDRESS(BUFFER)
           IX6       X6+X7         (X6) = ADDRESS(BUFFER)+NWXF
           SA6       A7-B7         RESET (IN)
           WRITE     FET,R         WRITE BUFFER
           RJ        =XFETRET$     GET FET RETURN DATA
           NZ        X1,IOMXEI     ABANDON PROCESS IF ERROR
           EQ        XTEOI2        CYCLE
XEIMESG   DIS       3,EOI TO BE XTENDED BY   PRUS
          SPACE     3
          END
*DECK       IOMFAP
* =DECK      IOMFAP      IOMFAP      ASSEMBLY
          IDENT     IOMFAP
FILACT    TITLE     FILE ACTIVITY AND POSITIONING OPERATIONS
*CALL       IOMACTL
          IFEQ      OS,NOS         *
************************************                               (NOS)+
*    EXTERNAL TEXT COMMON DECKS    *                               (NOS)
************************************                               (NOS)
*         LIST      X              *                               (NOS)
          XTEXT     COMCSYS        *  SYSTEM REQUEST ROUTINES      (NOS)
          XTEXT     COMCCIO        *  I/O REQUEST PROCESSOR        (NOS)
          ENDIF                    *
************************************
COMMON    SPACE     2
***       COMMON BLOCK DECLARATION
*
* =PROCEDURE CDMASTA
*CALL        CDMASTA
          USE       0
          SPACE     3
************************************************************************
*                                                                      *
*         FILE ACTIVITY FUNCTIONS PROVIDE CONTROL OVER DYNAMIC         *
*         ASSIGNMENT OF PERIPHERAL EQUIPMENT, OPENING, CLOSING         *
*         ERASING, AND POSITIONING OF LOGICAL/ILLOGICAL FILES          *
*                                                                      *
************************************************************************
*                                                                      *
*         PROGRAMMED BY C.A. FELIPPA, NOV 1975                         *
*                                                                      *
*         UPDATE -  NOV 1977                                           *
*                                                                      *
*         A FUNCTION SUMMARY FOLLOWS.                                  *
*                                                                      *
*         BSKIPR    BACKWARD SKIP LOGICAL RECORDS                      *
*                                                                      *
*         BSKIPF    BACKWARD SKIP FILES                                *
*                                                                      *
*         FSKIPR    FORWARD SKIP  LOGICAL RECORDS                      *
*                                                                      *
*         FSKIPF    FORWARD SKIP  FILES                                *
*                                                                      *
*         IOMCLS    CLOSES A LOGICAL FILE WITH RETURN.                 *
*                                                                      *
*         IOMEVT    DISCARDS CONTENTS OF FILE. LOGICAL FILENAME        *
*                   REMAINS ATTACHED TO JOB CONTROL POINT.             *
*                                                                      *
*         IOMOPN    OPENS A LOGICAL FILE.                              *
*                                                                      *
*         IOMPOD    POSITIONS DIRECT ACCESS DEVICE  ACCORDING TO       *
*                   DMGASP LOCATION PARAMETERS                         *
*                                                                      *
*         IOMPOT    POSITIONS MAGNETIC TAPE DEVICE ACCORDING TO        *
*                   DMGASP LOCATION PARAMETERS                         *
*                                                                      *
*         IOMREW    POSITION FILE TO BOI (REWIND)                      *
*                                                                      *
*         IOMRMT    REQUESTS MAGNETIC TAPE ASSIGNMENT                  *
*                   (PRESENTLY DEACTIVATED)                            *
*                                                                      *
************************************************************************
IOMCLS    SPACE     2
***       IOMCLS  (LFN)
*
*         ENTRY POINT TO CLOSE A LOGICAL FILE. THIS OPERATION
*         TERMINATES FILE ACTIVITY.
*
*         FORTRAN REFERENCE -
*
*         CALL    IOMCLS  (LFN)
*
*         WHERE
*
*         LFN       LOGICAL FILENAME
*
          ENTRY     IOMCLS
IOMCLS    BSS       1              ENTRY/EXIT POINT
          SX2       0104B          R-BIT=0,EP-BIT=1,XP-BIT=0,FETL=4
          MX4       0              N = 0
          SX3       X1             DUMMY BUFFER ADDRESS
          MX5       0
          SX6       B0
          RJ        =XFETSET$      ESTABLISH FET
+         SA2       =7HRETURN,
          RJ        FAMESG         PRINT INFORMATIVE MESSAGE
          CLOSE     FET,RETURN,R   CLOSE WITH RETURN
          SA5       IOMCLS         FETCH RETURN INSTRUCTION
          EQ        FAEXIT         TO EXIT SECTION
*
IOMEVT    SPACE     2
***       IOMEVT  (LFN)
*
*         ENTRY POINT TO EVICT (ERASE IN UNIVAC PARLANCE) A FILE
*
*         FORTRAN REFERENCE -
*
*         CALL   IOMEVT  (LFN)
*
*         WHERE
*
*         LFN       LOGICAL FILE NAME.  CONTENTS OF LFN ARE
*                   DISCARDED. FILE IS NOT RELEASED FROM JOB.
*
          ENTRY     IOMEVT
IOMEVT    BSSZ      1              ENTRY/EXIT POINT
          SX2       0104B          R-BIT=0,EP-BIT=1,XP-BIT=0,FETL=4
          MX4       0              N = 0
          SX3       X1             DUMMY BUFFER ADDRESS
          MX5       0
          SX6       B0
          RJ        =XFETSET$      ESTABLISH FET
+         SA2       =7HEVICT,
          RJ        FAMESG         PRINT INFORMATIVE MESSAGE
          EVICT     FET,R          EVICT MACRO
          SA5       IOMEVT         FETCH RETURN INSTRUCTION
          EQ        FAEXIT         TO EXIT SECTION
*
IOMOPN    SPACE     2
***       IOMOPN  (LFN)
*
*         ENTRY POINT TO OPEN A FILE. THIS FUNCTION IS PRIMARILY
*         DESIGNED FOR ACQUIRING DEVICE ATTRIBUTE INFORMATION
*
*         FORTRAN REFERENCE -
*
*         CALL      IOMOPN  (LFN)
*
*         WHERE
*
*         LFN       LOGICAL FILENAME  (1-7 CHARS, LJ ZEROFILLED)
*                   ON RETURN, FNT POINTER INSERTED IN BITS 0-11
*
*         VALUES RETURNED IN COMMON BLOCK /CDMAST/ INCLUDE
*         DEVTYP    CDC DEVICE CODE (12 BITS)
*         PRUSIZ    PRU SIZE FOR DEVICE TO WHICH LFN IS ASSIGNED
*         FNTPNT    FNT POINTER, INSERTED IN LOW 12 BITS OF LFN
*
          ENTRY     IOMOPN
IOMOPN    BSSZ      1              ENTRY/EXIT POINT
          MX4       0              N = 0
          SX2       0104B          R-BIT=0,EP-BIT=1,XP-BIT=0,FETL=4
          MX5       0
          BX3       X1             DUMMY BUFFER ADDRESS
          SX6       B0
          RJ        =XFETSET$      ESTABLISH FET
          BX7       X1
          SA7       LFNADS         SAVE LFN ADDRESS
+         SA2       =5HOPEN,
          RJ        FAMESG         PRINT INFORMATIVE MESSAGE
          OPEN      FET,,R         ISSUE OPEN MACRO
          SA1       LFNADS         (X1) = LFN ADDRESS
          SA2       FET+1          (X2) = FET(2)
          SB7       B1
          MX0      -12D
          SA3       X1             (X3) = LFN
          SA4       FET+4          (X4) = FET(5)
          LX2       12D            RIGHTJUSTIFY DEVICE-TYPE FIELD
          LX4       12D            RIGHTJUSTIFY FNT POINTER
          BX6      -X0*X2          EXTRACT DEVICE TYPE
          BX7      -X0*X4          EXTRACT FNT POINTER
          SA6       DEVTYP
          MX0       42D
          BX3       X0*X3          CLEAR BITS FOLLOWING LFN
          LX4       30D            RIGHTJUSTIFY PRU SIZE FIELD
          BX6       X3+X7          INSERT FNT POINTER
          SA6       A3             STORE (LFN/FNTPNT)
          MX0      -15D
          BX6      -X0*X4
          SA6       PRUSIZ
          SA5       IOMOPN
          EQ        FAEXIT         TO EXIT SECTION
IOMPOD    SPACE     2
***       IOMPOD    (CDLOC, LCARG1, LCARG2, SECTOR)
*
*         ESTABLISH NEW POSITION OF DIRECT ACCESS DEVICE
*
*         FORTRAN REFERENCE -
*
*         CALL      IOMPOD   (CDLOC, LCARG1, LCARG2, SECTOR)
*
*         WHERE
*
*         CDLOC     ON ENTRY, CURRENT DEVICE LOCATION (SECTORS)
*                   ON EXIT,  UPDATED DEVICE LOCATION  (SECTORS)
*
*         LCARG1    FIRST LOCATION ARGUMENT IN DMPAST
*
*         LCARG2    SECOND LOCATION ARGUMENT IN DMPAST
*
*         SECTOR    DEVICE SECTOR SIZE IN WORDS
*
          ENTRY     IOMPOD
POSDAD    BSS       0
IOMPOD    BSSZ      1              ENTRY/EXIT
          SB7       1              (B7) = 1
          SB6       B7+B7          (B6) = 2
          SA2       A1+B7                                          (FTN)
          SA3       A1+B6                                          (FTN)
          SA4       A2+B6                                          (FTN)
          SA1       X1             (X1) = CDLOC                    (FTN)
          SA2       X2             (X2) = LCARG1                   (FTN)
          SA3       X3             (X3) = LCARG2                   (FTN)
          SA4       X4             (X4) = SECTOR                   (FTN)
          BX7       X2             (X7) = LCARG1
          SB3       X3             (B3) = LCARG2
          SB4       X4             (B4) = SECTOR
          BX6       X2
          EQ        B3,PDAD4       IF LCARG2=0, CDLOC=LCARG1 AND EXIT
          AX2       60D            (X2) = EXTENDED SIGN OF LCARG1
          BX6       X7-X2          (X6) = IABS(LCARG1)
          EQ        B4,B7,PDAD2    IF SECTOR=1, OMIT CONVERSION
          SX6       X6+77B
          AX6       6              (X6) = COVERING SECTOR COUNT (CSC)
PDAD2     PL        X7,PDAD3
          BX6       -X6            RESTORE LCARG1 SIGN
PDAD3     SA6       A1             SET CDLOC = COV.SECTOR COUNT (SIGNED)
          GT        B3,IOMPOD      EXIT IF ABSOLUTE POSITIONING
          IX6       X6+X1          ELSE (X6) = CDLOC + CSC
PDAD4     SA6       A1             SET NEW LOCATION
          EQ        IOMPOD         EXIT
*
IOMPOT    SPACE     2
***       IOMPOT    (LFN, CDLOC, NEWLOC)
*
*         POSITION MAGNETIC TAPE DEVICE THROUGH THE
*         DMGASP LOCATION PARAMETER
*
*         FORTRAN REFERENCE -
*
*         CALL      IOMPOT  (LFN, CDLOC, NEWLOC)
*
*         WHERE
*
*         LFN       LOGICAL FILENAME OF TAPE DEVICE
*
*         CDLOC     ON ENTRY, CURRENT DEVICE LOCATION.
*                   ON EXIT, CDLOC=NEWLOC IF NO ABNORMAL
*                   CONDITION IS DETECTED, ELSE CDLOC EXITS
*                   AT LAST ERROR FREE POSITION
*
*         NEWLOC    DESIRED LOCATION
*
*
          ENTRY     IOMPOT
POSTAP    BSS       0
IOMPOT    BSSZ      1              ENTRY POINT
          SX2       0114B          R-BIT=0,E-BIT=1,XP-BIT=1,FETL=4
          BX3       X1             DUMMY BUFFER ADDRESS
          SX4       B0             N=0
          MX5       0
          SX6       X2             DUMMY BUFFER EXTENT
          RJ        =XFETSET$      ESTABLISH FET
          SA2       A1+B7          (X2) = ADDRESS(CDLOC)           (FTN)
          SA3       A1+B6          (X3) = ADDRESS(NEWLOC)          (FTN)
          SA2       X2             (X2) = CDLOC                    (FTN)
          SA3       X3             (X3) = NEWLOC                   (FTN)
          IX7       X3-X2          (X7) = NEWLOC-CDLOC
          ZR        X7,IOMPOT      EXIT IF NEWLOC = CDLOC
          MX5       18D
          AX7       12D            (X7) = MOVFIL = FILES TO MOVE
          LX5       36D            (X5) = MASK FOR FILE/REC COUNT
          ZR        X7,TAPOS4
*
*         POSITIONING BY FILES
*
          AX2       12D            (X2) = CDFIL
          AX3       12D            (X3) = NEWFIL
          PL        X7,TAPOS2
          BX7       -X7
          SB3        X3            (B3) = NEWFIL
          SB2        X7            (B2) = MOVFIL
          GT        B3,B2,TAPOS2   TO BACKSKIP FILE SECTION IF
          REWIND    FET,R          REWIND TAPE
          SA1       FET            FETCH FET HEADER
          MX0       42D
          MX6       0              (X6) = 0
          BX1       X0*X1          CLEAR REO/RTN FIELD
          SX5       B6+B7          (X5) = 3
          SA6       A2             SET CDLOC = 0
          BX7       X1+X5          SET FILE MODE/INTERLOCK BITS
          SA7       A1             RESTORE FET HEADER
          EQ        B3,B0,TAPOS3   OMIT FORWARD SKIP IF NEWFIL=0
          SX7       B3             SET MOVFIL = NEWFIL
*
TAPOS1    BSS       0
          SA4       FSFMAC+1       FETCH OPERATION DESCRIPTOR
          LX7       18D            ROTATE MOVFIL
          BX4       X4*X5          CLEAR FILE COUNT FIELD (N)
          BX6       X4+X7          INSERT MOVFIL
          SA6       A4             STORE OP DESCRIPTOR
FSFMAC    SKIPF     FET,,17B,R     FORWARD SKIP FILES
          EQ        TAPOS3
TAPOS2    SA4       BSFMAC+1       FETCH OP DESCRIPTOR
          LX7       18D            ROTATE FILE COUNT
          BX4       X4*X5          CLEAR FILE COUNT FIELD
          BX6       X4+X7
          SA6       A4
BSFMAC    SKIPB     FET,,17B,R     BACKSKIP FILES
TAPOS3    LX3       12D            CDLOC = 4096*(NEWFIL-1)
          BX6       X3
          SA6       A2             UPDATE CDLOC
*
*         POSITION TAPE BY RECORDS
*
TAPOS4    BSS       0
          SA2       A2
          SA3       A3
          SA1       FET
          MX0       42D
          BX1       X0*X1
          BX6       X1+X3
          SA6       A1
          MX0       -12D
          IX7       X3-X2
          BX7       -X0*X7
          ZR        X7,TAPOS6
          PL        X7,TAPOS5
          SA4       BSRMAC+1
          BX7       -X7
          LX7       18D
          BX4       X4*X5
          BX6       X6+X7
          SA6       A4
BSRMAC    SKIPB     FET,,0,R       BACKSKIP RECORDS
          EQ        TAPOS6
TAPOS5    SA4       FSRMAC+1
          LX7       18D
          BX4       X4*X5
          BX6       X4+X7
          SA6       A4
FSRMAC    SKIPF     FET,,0,R       FORWARD SKIP RECORDS
*
TAPOS6    BX6       X3
          SA6       A2             SET CDLOC = NEWLOC
          EQ        IOMPOT         RETURN TO CALLING PROGRAM
*
IOMREW    SPACE     2
***       IOMREW  (LFN)
*
*         ENTRY POINT TO REWIND A FILE
*
*         FORTRAN REFERENCE -
*
*         CALL   IOMREW  (LFN)
*
*         WHERE
*
*         LFN       LOGICAL FILENAME
*
          ENTRY     IOMREW
IOMREW    BSSZ      1              ENTRY/EXIT POINT
          MX3       0
          SX2       0104B
          MX4       0
          SX5       B0
          MX6       0
          RJ        =XFETSET$      ESTABLISH FET
          REWIND    FET,R          REWIND MACRO
          RJ        FETRET$        GET RET/AT CODES
          EQ        IOMREW         RETURN TO CALLING PROGRAM
SKPSYST   IFEQ      OS,SCOPE
***       BSKIPR/BSKIPF/FSKIPR/FSKIPF (LFN, N)
*
*         ENTRY POINTS TO SKIP RECORDS OR FILES
*
*         FORTRAN REFERENCES -
*
*         -----------------------
*         CALL   BSKIPR  (LFN, N)
*         CALL   BSKIPF  (LFN, N)
*         CALL   FSKIPR  (LFN, N)
*         CALL   FSKIPF  (LFN, N)
*         -----------------------
*
*         WHERE
*
*         LFN       LOGICAL FILE NAME
*
*         N         NO. OF RECORDS OR FILES TO BE SKIPPED
*                   (MAX. 77776B)
*
*
          ENTRY     BSKIPR,BSKIPF,FSKIPR,FSKIPF
BSKIPF    BSSZ      1
          SA4       BSKIPF         FETCH RETURN INSTRUCTION
          SB4       17B            LEVEL=17B (FILE)
          SB5       1              B5=1 FOR BACKWARD SKIP
          EQ        SKIP1
BSKIPR    BSSZ      1              ENTRY POINT
          SA4       BSKIPR         FETCH RETURN INSTRUCTION
          SB4       B0             LEVEL=0  (RECORD)
          SB5       1              B5=1 FOR BACKWARD SKIP
          EQ        SKIP1
FSKIPF    BSSZ      1              ENTRY POINT
          SA4       FSKIPF         FETCH RETURN INSTRUCTION
          SB4       17B            LEVEL=17B (FILE)
          SB5       B0             B5=0 FOR FORWARD SKIP
          EQ        SKIP1
FSKIPR    BSSZ      1              ENTRY POINT
          SA4       FSKIPR         FETCH RETURN INSTRUCTION
          SB4       B0             LEVEL=0  (RECORD)
          SB5       B0             B5=0 FOR FORWARD SKIP
SKIP1     BSS       0
          BX6       X4             (X6) = RETURN INST
          SA6       SKPRET         STORE RETURN INSTRUCTION
          MX3       0
          SX2       0104B
          MX4       0
          SX5       B0
          MX6       0
          RJ        =XFETSET$      ESTABLISH FET
          SA2       A1+B7          ADDRESS(N) TO X2                (FTN)
          SA2       X2             (X2) = N                        (FTN)
          SA3       SKPTAB+B5      FETCH CPC ARGUMENT WORD
          MX0       42D
          SX5       B4             (X5) = RECORD LEVEL
          BX2      -X0*X2          LIMIT N TO 6 OCTAL DIGITS
          LX5       14D            ROTATE LEVEL FOR INSERTION
          LX2       18D            ROTATE N
          BX6       X3+X5          INSERT LEVEL
          BX6       X6+X2          INSERT N
          SA6       SKPMAC+1       STORE AFTER CPC REFERENCE
SKPMAC    SA1       FET
          RJ        =XCPC          ISSUE REQUEST
          BSSZ      1
          RJ        FETRET$        GET CODE/STATUS
SKPRET    BSSZ      1              RETURN TO CALLING PROGRAM
          USE       1
SKPTAB    BSS       0
          VFD       18D/3,2/1,40D/240B    FSKIP REQUEST WORD
          VFD       18D/3,2/1,40D/640B    BSKIP REQUEST WORD
          USE       0
SKPSYST   ENDIF
FAMESG    SPACE     2
**        UTILITY BLOCK TO PRINT INFORMATIVE MESSAGE
*
          EXT       IOMESSG,LFNBF$,NCOCTL$
FAMESG    BSS       1
          SA3       =6H0+++
          SA1       FET             (X1) = LFN
          BX7       X2
          SA7       ASTMSG+1       PUT OP ID IN ASTMSG(2)
          BX6       X3
          SA6       ASTMSG         INITIALIZE ASTMSG(1)
          RJ        =XLFNBF$       BLANKFILL LFN IN (X6)
          SA6       A7+B7          STORE LFN IN ASTMSG(3)
          RJ        =XIOMESSG      PRINT MESSAGE
          SB1       1              RESTORE (B1) = 1
          EQ        FAMESG
*
**        UTILITY CODE BLOCK FOR TERMINATION ACTIVITIES
*
*         ENTRY -   (X5) = RETURN INSTRUCTION
*
FAEXIT    BSS       0
          BX7       X5
          SA7       FARETRN        STORE RETURN INST
          RJ        =XFETRET$      GET RETURN PARAMETERS FROM FET
          ZR        X1,FARETRN     EXIT IF STATUS = 0
          RJ        =XNCOCTL$      ENCODE STATUS IN (X6)
          SA5       =10HFAC STATUS
          SA6       ASTMSG+2       PLACE STATUS IN ASTMSG(3)
          BX7       X5
          SA7       A6-B7          EXPLANATORY TEXT TO ASTMSG(2)
          RJ        =XIOMESSG      PRINT STATUS MESSAGE
FARETRN   PS                       RETURN TO CALLING PROGRAM
*
          END
*DECK       IOMFIP
* =DECK      IOMFIP      IOMFIP      ASSEMBLY
          IDENT     IOMFIP
          TITLE     FILE INFORMATION/IDENTIFICATION PROCEDURES
ASMCTL    SPACE     3
*CALL       IOMACTL
          IFEQ      OS,NOS         *
************************************                               (NOS)
*    EXTERNAL TEXT COMMON DECKS    *                               (NOS)
************************************                               (NOS)
          ENDIF                    *
************************************
COMMON    SPACE     2
***       COMMON BLOCK DECLARATION
*
* =PROCEDURE CDMASTA
*CALL        CDMASTA
*
          USE       /CDMPAD/
CMSIZ     BSS       1
BCSIZ     BSS       1
REQFL     BSS       1
LWAREC    BSS       1
BUFFER    BSS       0
PAD       BSS       300B
*
          USE       0
          SPACE     3
************************************************************************
*                                                                      *
*         FILE INFORMATION FUNCTIONS INCLUDE FILENAME MANIPULATION     *
*         AND FILE/DEVICE STATUS ACQUISITION.                          *
*                                                                      *
*         PROGRAMMED BY C.A. FELIPPA, OCT 1975  (HALLOWEEN DAY)        *
*         UPDATE -  OCT 1977 (HALLOWEEN DAY)                           *
*                                                                      *
************************************************************************
*                                                                      *
*         A SUMMARY LIST OF PROCEDURES FOLLOWS.                        *
*                                                                      *
*         FETSET$   SETS UP A FILE ENVIRONMENT TABLE (FET)             *
*                                                                      *
*         FETRET$   EXTRACTS RETURNS PARAMETERS FROM CURRENT FET.      *
*                                                                      *
*         IOMLDIX   EXTRACTS INFORMATION PERTAINING TO A LOGICAL       *
*                   DEVICE INDEX IN FORMAT SUITABLE FOR DISPLAY.       *
*                                                                      *
*         IOMLFN    QUERIES STATUS OF FILENAME IN RELATION TO JOB      *
*                                                                      *
*         IOMQFC    BREAKS UNIVAC-TYPE DEVICE NAME INTO QUALIFIER      *
*                   (=OWNER'S ID), FILENAME, AND FILE CYCLE            *
*                                                                      *
*         LFNBF     (ALT COMPASS ENTRY LFNBF$) BLANKFILLS A LFN        *
*                                                                      *
*         LFNZF     (ALT COMPASS ENTRY LFNZF$) ZERO FILLS A LFN        *
*                                                                      *
*         LJRJN    LEFTJUSTIFY A RIGHT-JUSTIFIED NAME
*                                                                      *
*         LMXXXX    WHERE XXXX =  EQPC,DLOC,NEXT,SECT,UNIT   ARE       *
*                   FUNCTIONS TO GET AST INFORMATION FOR A GIVEN LDI.  *
*                                                                      *
*         RFNBF     (ALT COMPASS ENTRY RJNBF$) BLANKFILLS A
*                   ZEROFILLED RIGHT-JUSTIFIED NAME STRING
*                                                                      *
*         NCOCTL$   COMPASS-CALLABLE PROCEDURE FOR CONVERTING AN       *
*                   1-9 DIGIT INTEGER TO OCTAL DISPLAY CODE            *
*                                                                      *
************************************************************************
FETSET$   SPACE     2
***       FETSET$
*
FETSET$   SPACE     2
*
*         COMPASS-CALLABLE PROCEDURE FOR SETTING UP
*         A FILE ENVIRONMENT TABLE (FET)
*
*         COMPASS REFERENCE -
*
*         RJ        FETSET$
*
*         ENTRY REGISTER SET -
*         (X1)      ADDRESS(42/LFN,18/FNT-POINTER)
*                   (LAST FIELD OPTIONAL)
*         (X2)      48/0,3/R,3/EP,3/XP,3/FETL,    WHERE
*                   R = RANDOM ACCESS BIT, EP = ERROR PROCESSING BIT,
*                   XP = EXTENDED ERROR PROC BIT, FETL = SIZE(FET)-5
*         (X3)      ADDRESS(BUFFER)
*         (X4)      N = SIZE OF BLOCK TO BE XMITTED
*         (X5)      0  IF READ CONDITION,   N  IF WRITE
*         (X6)      LIMIT-ADDRESS(BUFFER)-N
*
*         EXIT REGISTER CONFIGURATION -
*         (B1)=1, (B7)=1, (B6)=2
*         B2,B3,B4,B5,A0,A1,A2,A3,X1,X3        PRESERVED
*         A4,A5,A6,A7,X0,X2,X4,X5,X6,X7        DESTROYED
*         ENTRY VALUES OF (X4) AND (X5) PLACED IN NWXF AND NWXWRT
*         (BLOCK /CDMAST/), RESPECTIVELY.
*
*
*         EXIT FET CONFIGURATION (SCOPE) -
*
*  WORD / BIT      5         4         3         2         1
*         987654321098765432109876543210987654321098765432109876543210
*  FET+0  ----------LOGICAL-FILENAME----------------................11
*  FET+1  ............R..E...X..................FETL-------FIRST------
*  FET+2  ..........................................--------IN--------
*  FET+3  ..........................................--------OUT-------
*  FET+4  -FNTPOINTER-..............................-------LIMIT------
*  FET+5  ............................................................
*  FET+6  ............-(FETEXT-POINTER)-..............................
*  FET+7  ............................................................
*  FET+8  ............-EOI-XFER-ADDRESS-...........---ERROR-ADDRESS---
*
*         WHERE -
*         .         ZERO BIT
*         FIRST     ADDRESS(BUFFER)
*         IN        ADDRESS(BUFFER)     ON READ-TYPE CONDITION
*                   ADDRESS(BUFFER)+N   ON WRITE-TYPE CONDITION
*         OUT       ADDRESS(BUFFER)
*         LIMIT     ADDRESS(BUFFER)+N+(X6)
*         FETEXT POINTER      ONLY SET IF XP-BIT = 1
*
*         FOR NOS, WORDS FET+6 AND FET+8 ARE ZERO, AND THE XP BIT
*         (WORD FET+1) HAS NO EFFECT.
*
          ENTRY     FETSET$
FETSET$   BSSZ      1              ENTRY/EXIT
          SB7       1              (B7) = 1
          BX7       X4             (X7) = N
          IX4       X3+X4          (X4) = ADDRESS(BUFFER)+N
          SB6       B7+B7          (B6) = 2
          NZ        X6,*+1
          SX6       B7             IF (X6) = 0, SET (X6) = 1
+         SA7       NWXF           SAVE N IN NWXF
          BX7       X5
          IX6       X4+X6          (X6) = LIMIT
          SA7       A7+B7          SAVE ENTRY (X5) IN NWXWRT
          MX7       0              (X7) = 0
          SA6       FET+4          SAVE LIMIT IN FET+4 = FET(5)
          IFEQ      OS,SCOPE
          SX6       CPCERR         FETCH ERROR-XFER ADS          (SCOPE)
          BX0       X6             (X0) = ERROR XFER ADS         (SCOPE)
          LX0       30                                           (SCOPE)
          BX6       X0+X6          COMPLETE ASSEMBLY OF FET(9)   (SCOPE)
          ELSE
          MX6       0              (X6) = 0                        (NOS)
          ENDIF
          SA7       RETCOD         CLEAR RETCOD
          SB1       X1             SAVE (X1) IN B1
          SA7       A7+B7          CLEAR EOFCOD
          SA6       FET+8          STORE FET(9)
          SA7       A7+B7          CLEAR STATUS
          SA7       A7+B7          CLEAR TAPERR/DTLERR
          SA7       A7+B7          CLEAR RSKCNT
          BX6       X3             (X6) = OUT = ADDRESS(BUFFER)
          SA7       A7+B7          CLEAR NWRDXF
          SA7       A6-B7          CLEAR FET(8)
          MX0       42D            (X0) = LFN MASK
          SA7       A7-B7          CLEAR FET(7)
          SA7       A7-B7          CLEAR FET(6)
          IX7       X3+X5          (X7) = IN =  ADDRESS(BUFFER)+(X5)
          SA6       A7-B6          FET(4) = OUT
          SA5       X1             (X5) = LFN/FNTPNT
          SA7       A6-B7          FET(3) = IN
          SX1       B6+B7          (X1) = 3
          BX6       X0*X5          (X6) = ISOLATED LFN
          BX5       -X0*X5         (X5) = ISOLATED FNTPNT
          SA4       A7+B6          (X4) = LIMIT = FET(5)
          BX6       X6+X1          SET INTERLOCK AND XMISSION MODE BITS
          MX0       -3             (X0) = OCTAL DIGIT MASK
          SA6       A7-B6          STORE FET-HEADER IN FET(1)
          LX5       48D            (X5) = LEFTJUSTIFIED FNTPNT
          BX1       -X0*X2         (X1) = FETL
          BX7       X5+X4          (X7) = MERGED FNTPNT/LIMIT FIELDS
          AX2       3              RIGHTJUSTIFY R/E/X BITS FIELD
          SA7       A4             STORE FET(5)
          BX4       -X0*X2         (X4) = XP BIT
          BX2       X0*X2          CLEAR XP-BIT FIELD
          LX2       1              SHIFT R/E BITS TO PROPER DISTANCE
          BX2       X2+X4          REINSERT XP BIT
          LX1       18D            ROTATE FETL
          LX2       40D            POSITION R/E/X FIELDS
          BX1       X1+X3          (X1) = MERGED FETL/FIRST FIELDS
          BX6       X1+X2          (X6) = MERGED R/E/X/FETL/FIRST FIELDS
          SA6       A6+B7          STORE FET(2)
          SX1       B1             RESTORE (X1)
          SB1       B7             (B1) = 1  FOR NOS
          IFEQ      OS,SCOPE
          ZR        X4,FETSET$     EXIT IF XP=0
          SX7       FETEXT         (X7) = ADDRESS OF FET EXTENSION
          SX6       B7             (X6) = 1
          SA6       X7             FETX(1) = 1
          LX7       30D            ROTATE ADDRESS TO BITS 30-47
          SA7       A7+B6          STORE FETX-PNT IN FET(7)
          ENDIF
          EQ        FETSET$        RETURN TO PROCEDURE CALLER
*
***       FETSET  (LFN, X2, BUFFER, N, NWRT)
*
*
*         FORTRAN-CALLABLE FORM OF FETSET$.  USED PRIMARILY
*         FOR DEBUGGING PURPOSES
*
*         FORTRAN REFERENCE
*
*         CALL      FETSET  (LFN, X2, A, N, NWRT)
*
          ENTRY     FETSET
FETSET    BSSZ      1
          SB7       1                                              (FTN)
          SA2       A1+B7                                          (FTN)
          SA3       A2+B7                                          (FTN)
          SA2       X2                                             (FTN)
          SA4       A3+B7                                          (FTN)
          SA5       A4+B7                                          (FTN)
          SA4       X4                                             (FTN)
          SA5       X5                                             (FTN)
          SX6       B7
          RJ        FETSET$
          EQ        FETSET         RETURN TO FORTRAN PROGRAM
*
FETRET$   SPACE     2
***       FETRET$
*
*         COMPASS-CALLABLE PROCEDURE TO EXTRACT STATUS PARAMETER
*         FIELDS FROM THE F.E.T. AND PUT'EM IN SINGLE WORDS
*
*         COMPASS REFERENCE -
*
*         RJ        FETRET$
*
*         EXIT VALUES -
*
*         (B7)=1, (B6)=2, (X1)=STATUS
*         RETCOD,EOICOD,STATUS,DTLERR      STORED IN /CDMAST/
*         NWRDXF    UPDATED BY  OUT-IN+NWXWRT
*
*         REGISTER UTILIZATION -
*         B1,B2,B3,B4,B5,A0,A4,A5,X0,X4,X5    PRESERVED
*         A1,A2,A3,A6,A7,X1,X2,X3,X6,X7       DESTROYED
*
          ENTRY     FETRET$
FETRET$   BSSZ      1              ENTRY/EXIT
          SB7       1
          SA1       FET+0          (X1) = FET HEADER
          SB6       B7+B7          (B6) = 2
          MX6       -9D            (X6) = RETURN CODE MASK
          SA2       A1+B6          (X2) = IN = FET+2
          BX6       -X6*X1         (X6) = RETCOD
          SA3       A2+B7          (X3) = OUT = FET+3
          SA6       RETCOD         STORE RETURN CODE
          AX1       9              RIGHTJUSTIFY EOI INDICATOR
          MX6       -1
          IX7       X3-X2          (X7) = OUT-IN
          SA2       NWXWRT         (X2) = NWXF ON WRITE OP, ELSE 0
          SA3       NWRDXF         (X3) = CURRENT NWRDXF
          SA7       OUTMIN         PLACE (OUT-IN) IN OUTMIN
          BX6       -X6*X1         (X6) = EOICOD
          IX7       X2-X7          (X7) = IN-OUT+NWXWRT
          SA6       A6+B7          STORE EOICOD
          IX7       X7+X3
          SA7       A3             STORE UPDATED NWRDXF
          IFEQ      OS,SCOPE
          SA1       A6+B7          FETCH STATUS WORD             (SCOPE)
          ELSE
          AX1       1              RIGHTJUSTIFY ABT CODE           (NOS)
          MX6       -4                                             (NOS)
          BX6       -X6*X1         (X6) = ABT CODE                 (NOS)
          LX1       X6                                             (NOS)
          SA6       A6+B7          STORE IN STATUS                 (NOS)
          ZR        X6,FETRET$                                     (NOS)
          SA1       FET+6                                          (NOS)
          SX2       X6-11B                                         (NOS)
          MX3       -12D                                           (NOS)
          BX6       -X3*X1                                         (NOS)
          NZ        X2,FETRET$                                     (NOS)
          SA6       A6+B7          STORE DETAILED ERROR CODE       (NOS)
          ENDIF
          EQ        FETRET$        RETURN
CPCERR    SPACE     2
***       CPCERR
*
*         OWNCODE ERROR PROCESSING PROCEDURE.  NOTE THAT THIS
*         CODE BLOCK USES ONLY REGISTERS A1,X1,A6,X6,X0.   THIS
*         IS IMPORTANT, FOR CPC USES ONLY THE 1ST FOUR.
*
          IFEQ      OS,SCOPE
CPCERR    BSSZ      1                                            (SCOPE)
          BX6       X1                                           (SCOPE)
          AX1       9D             RIGHTJUSTIFY STATUS FIELD     (SCOPE)
          SA6       FET            FIX TO GODDAMN SCOPE, 5/79    (SCOPE)
          MX0       -5             MASK FOR STATUS FIELD         (SCOPE)
          BX6       -X0*X1         (X6) = STATUS                 (SCOPE)
          SA1       FET+6          (X1) = FET(7)                 (SCOPE)
          SA6       STATUS         STORE STATUS WORD             (SCOPE)
          AX1       30D            RIGHTJUSTIFY FETX-PNT FIELD   (SCOPE)
          ZR        X1,CPCERR      RETURN IF XP=0                (SCOPE)
          SA1       X1             (X1) = FET EXTENSION WORD     (SCOPE)
          BX6       X1             SAVE (X1) IN (X6)             (SCOPE)
          AX6       18D            RIGHTJUSTIFY DETAILED ERROR   (SCOPE)
          BX6       -X0*X6         (X6) = TAPERR                 (SCOPE)
          AX1       24D            RIGHTJUSTIFY RES SKIP COUNT   (SCOPE)
          MX0       -16D                                         (SCOPE)
          SA6       A6+B7          STORE TAPERR                  (SCOPE)
          BX6       -X0*X1         (X6) = RSKCNT                 (SCOPE)
          SA6       A6+B7          STORE RSKCNT                  (SCOPE)
          EQ        CPCERR         TO CPC EXIT WORD              (SCOPE)
          ENDIF
IOMLDIX   SPACE     2
***       IOMLDIX
*
*         EXTRACT INFORMATION PERTAINING TO A LOGICAL DEVICE INDEX
*         (LDIX) AND PLACE IT IN FORMAT SUITABLE FOR TABLE PRINT
*         BY SUBROUTINE IOMTAB.
*         ALL INPUT/OUTPUT IS DONE THROUGH BLOCK /CDMPAD/.
*
          ENTRY     IOMLDIX
IOMLDIX   BSSZ      1
          SA1       LDIX           (X1) = LDI INDEX
          SB7       1              (B7) = 1
          SB2       MAXLDI         (B2) = MAXLDI = AST ROW DIMENSION
          SB1       X1             (B1) = LDI
          SB6       B7+B7          (B6) = 2
          SA3       B1+ASTYPE-1    (X3) = ASTYPE(LDI)
          SB3       B2+B2          (B3) = 2*MAXLDI
          SA2       A3-B2          (X2) = ASTOPT(LDI)
          SA5       A3+B3          (X5) = ASTLOC(LDI) = CDLOC
          SX7       X3-4           (X7) = ASTYPE(LDI)-4 = TYPEX
          BX6       X2             (X6) = OPTX
          SA7       TYPEX          STORE TYPEX
          SA1       ASTSEC+4+X7    (X1) = ASTSEC(TYPEX+4) = SECTOR
          SA6       A7+B7          STORE OPTX
          BX6       X5             (X6) = CDLOC
          SA2       A5+B2          (X2) = ASTNXT(LDI)
          SA6       A6+B6          STORE CDLOC
          BX7       X1             (X7) = SECTOR
          SA1       =10H           (X1) = BLANK WORD
          SB4       X7             SAVE SECTOR IN (B4)
          SA3       A2+B2          (X3) = ASTLIM(LDI)
          SA7       A7+B6          STORE SECTOR
          SA4       A3+B2          (X4) = ASTWXR(LDI)
          BX6       X2             (X6) = NEXT
          SA5       A4+B2          (X5) = ASTWXW(LDI)
          BX7       X3             (X7) = LIMIT
          SA6       A6+B7          STORE NEXT
          BX6       X1             (X6) = BLANK
          SA7       A6+B7          STORE LIMIT
          SA6       A6+B6          STORE TRANSPARENT FULL DEV MARK
          LX7       X4             (X7) = KWXRED
          BX6       X5             (X6) = KWXWRT
          SA4       ASTCNT         (X4) = KACTVD (ACTIVE DEVICE COUNTER)
          SA7       A7+B6          STORE KWXRED
          SA6       A6+B6          STORE KWXWRT
          SX6       X4+B7
          BX0       X1             SAVE BLANK WORD IN (X0)
          SA6       A4             STORE INCREMENTED KACTVD
          SA5       A4+B7          (X5) = KFULLD (FULL   DEVICE COUNTER)
          PL        X3,IOMLDI1     TEST FOR FULL DEVICE (NEG LIMIT)
          SX7       1R*
          LX7       54D
          SX6       X5+B7          INCREMENT KFULLD BY 1
          SA7       A7-B7          STORE FULL DEVICE MARK
          SA6       A5             STORE UPDATED KFULLD
IOMLDI1   BSS       0
          SA1       TABFMT14       (X1) = TABFMT(1)
          BX5       X0             (X5) = TABFMT(5) (DIR. ACCESS DEVICE)
          SA2       A1+B7          (X2) = TABFMT(2)
          SA3       A1+B6          (X3) = TABFMT(3)
          BX6       X1
          SA6       TABFMT+0       STORE TABFMT(1)
          BX7       X2
          SA4       A3+B7          (X4) = TABFMT(4) (DIR. ACCESS DEVICE)
          BX6       X3
          SA7       A6+B7          STORE TABFMT(2)
          SA1       A4+B7          (X1) = TABFMT(6)
          SA2       A4+B6          (X2) = TABFMT(7)
          SA6       A6+B6          STORE TABFMT(3)
          BX7       X0             (X7) = BLANK
          GT        B4,IOMLDI2     BRANCH AS PER SECTOR VALUE
          SA4       A2+B7          (X4) = TABFMT(4)  (TAPE DEVICE)
          SA5       A2+B6
          SA7       LIMIT          BLANK OUT LIMIT  WORD
          SA7       SECTOR         BLANK OUT SECTOR WORD
IOMLDI2   BSS       0
          LX6       X4
          BX7       X5
          SA6       A6+B7          STORE TABFMT(4)
          BX6       X1
          SA7       A6+B7          STORE TABFMT(5)
          BX7       X2
          SA1       ASTLFN-1+B1    (X1) = ASTLFN(LDI)
          SA6       A6+B6          STORE TABFMT(6)
          SA5       A1-B2          (X5) = PFN = ASTPFN(LDI)
          SA7       A7+B6          STORE TABFMT(7)
          BX7       X5
          SA7       PFN
          RJ        LFNBF$         BLANKFILL LFN IN (X6)
          SA6       LFNAME         STORE BLANK-PADDED LFN
          ZR        X5,IOMLDIX     EXIT IF PFN=0 (LOCAL FILE)
          BX1       X5             (X1) = PFN
          RJ        LFNBF$         BLANKFILL PFN IN (X6)
          MX0       -6
          SA6       PFN            STORE BLANK-PADDED PFN
          BX6       -X0*X5         (X6) = PFN CYCLE
          SA6       A6+B7          STORE PFNCY
          SA1       A5-B2          (X1) = PFNID = ASTQFR(LDI)
          RJ        RFNBF$         BLANKFILL PFNID IN (X6)
          SA6       PFNID          STORE BLANK-PADDED PFNID
          EQ        IOMLDIX        RETURN TO CALLING PROGRAM
TABFMT14  DIS       4,(2H +I3,  2XA7,2XO4, 2I4,     I4,3I7,
TABFMT67  DIS       2,A1,2I8,2H +)
TABFMT45  DIS       2,A4,1XO6,1XO6,A7,               (TAPE DEVICE)
LDIX      EQU       PAD+64
LFNAME    EQU       PAD+65
EQCODE    EQU       PAD+66
TYPEX     EQU       PAD+67
OPTX      EQU       PAD+68
SECTOR    EQU       PAD+69
CDLOC     EQU       PAD+70
NEXT      EQU       PAD+71
LIMIT     EQU       PAD+72
MARK      EQU       PAD+73
KWXRED    EQU       PAD+74
KWXWRT    EQU       PAD+75
PFN       EQU       PAD+76
PFNCY     EQU       PAD+77
PFNID     EQU       PAD+78
TABFMT    EQU       PAD+80
*
IOMLFN    SPACE     2
***       IOMLFN    (LFN)
*
*         FUNCTION TO QUERY STATUS OF LOGICAL FILE NAME IN
*         RELATION TO JOB
*
*         FORTRAN REFERENCE -
*
*         LFNST =   IOMLFN  (LFN)
*
*         WHERE
*
*         LFN       LOGICAL FILENAME
*
*         IOMLFN    ZERO,  LFN IS NOT ASSIGNED TO JOB
*                   NEGATIVE,  LFN IS A LOCAL FILE
*                   POSITIVE, LFN IS ATTACHED PERM FILE
*                   BITS 0-4 OF IOMLFN CONVEY INFORMATION AS
*
*                   REGARDS ACCESS PERMISSIONS (SEE SCOPE 3.4 MANUAL)
          ENTRY     IOMLFN
IOMLFN    BSS       1              ENTRY/EXIT
          MX7       0              (X7) = 0
          SA5       X1             LFN TO (X5)                     (FTN)
          SA7       FET+2
          SB7       1
          SA7       A7-B7
          MX0       42D            GENERATE LFN MASK
          SA6       A7-B7          SET LIST HEADER
          BX6       X0*X5
          SA6       A7             STORE LFN
          IFEQ      OS,SCOPE
          PERM      FET,RC         PERM MACRO                    (SCOPE)
          ENDIF
          SA5       FET            (X5) = EXIT WORD
          MX0       -9D
          AX5       9D             RIGHTJUSTIFY RETURN FIELD
          BX5       -X0*X5         EXTRACT RETURN FIELD
          SX6       X5             PLACE IN (X6)
          AX5       4              RIGHTJUSTIFY BIT 13
          ZR        X5,IOMLFN      EXIT IF PERM OR NONEXISTING FILE
          BX6       -X6            COMPLEMENT (X6) IF LOCAL FILE
          EQ        IOMLFN         RETURN
*
IOMQFC    SPACE     2
***       IOMQFC    (EDN, QFC)
*
*         TO BREAK DOWN UNIVAC-TYPE DEVICE NAME TEXTSTRING INTO
*         PRIMITIVE COMPONENTS - QUALIFIER, FILENAME, CYCLE
*
*         FORTRAN REFERENCE -
*
*         CALL      IOMQFC  (EDN, QFC)
*
*         WHERE
*
*         EDN       EXTERNAL DEVICE NAME SUPPLIED (AS 2ND ARGUMENT)
*                   TO DMDAST.  ITS GENERAL FORM IS
*                   QUALIFIER*FILENAME(FCYCLE), 20 CHARS MAX
*                   FIRST/LAST COMPONENTS ARE OPTIONAL
*
*         QFC       THREE WORD OUTPUT ARRAY RECEIVING -
*                   QFC(1)    QUALIFIER (1-7 CHARS) RJ, ZEROFILLED
*                   QFC(2)    FILENAME  (1-7 CHARS) LJ, ZEROFILLED
*                   QFC(3)    DECODED CYCLE NUMBER
*                   IF ANY COMPONENT IS MISSING, THE CORRESPONDING
*                   ENTRY OF QFC WILL RECEIVE ZERO.
*
          ENTRY     IOMQFC
GETQFC    BSS       0
IOMQFC    BSSZ      1
          SB7       1              (B7) = 1
          MX0       6              (X0) = CHAR MASK
          SA2       A1+B7          (X2) = ADDRESS(QFC)             (FTN)
          MX6       0              (X6) = 0                        (FTN)
          SA1       X1             (X1) = EDN(1)                   (FTN)
          MX7       0              (X7) = 0                        (FTN)
          SA2       X2             (A2) POINTS TO QFC(1)           (FTN)
          SB6       1R(            (B6) = FCYCLE DELIMITER
          SB5       1R*            (B5) = QUALIFIER DELIMITER
          SA6       A2             QFC(1) = 0
          SA7       A2+B7          QFC(2) = 0
          SX5       -2             (X5) = - MAX. WORDS IN EDN
          SB3       60-48          (B3) = 60-48, 48 BEING MAX BITS/QF
          SB4       1R9            (B4) = LARGEST ALPHANUMERIC CHAR
          LX0       6              (X0) = RIGHT JUSTIFIED CHAR MASK
          SA6       A7+B7          QFC(3) = 0
          SX4       1R0            (X4) = 1R0 FOR FCYCLE DECODE
*
GETQFC1    BSS       0
           MX6       0             (X6) = 0
           SB2       60            INITIALIZE (X6)-LJ COUNTER
           MX7       0
GETQFC2    BSS       0
           LX1       6             RIGHTJUSTIFY NEXT CHAR
           BX2       X0*X1         ISOLATE CHAR IN (X2)
           SB1       X2            PLACE CHAR IN (B1) FOR TESTS
           BX1      -X0*X1         CLEAR VACATED POSITION IN (X1)
           EQ        B1,GETQFC7    GET OFF SCANLOOP ON ZERO BYTE
           GT        B1,B4,GETQFC4 TEST FOR SPECIAL CHAR (CODE GT 1R9)
           LE        B2,B3,GETQFC3 LIMIT (X6)STRING TO 7 CHARACTERS
           LX6       6             FOREPLAY ON (X6)
           SB2       B2-6          DECREMENT LEFTJUSTIFIER COUNT
           BX6       X2+X6         SIX BITS TO PASSION PIT
           LX7       B2,X6         (X7) = LEFTJUSTIFIED OUTPUT STRING
GETQFC3    BSS       0
           NZ        X1,GETQFC2    TEST FOR SOURCE STRING EXHAUSTION
           SX5       X5+B7         INCREMENT EDN WORD COUNT
           SA1       A1+B7         LOAD NEXT EDN WORD IN (X1)
           NG        X5,GETQFC2    CONTINUE SCAN IF (X5) LT 0
           EQ        GETQFC7       ELSE GET OFF LOOP
GETQFC4    BSS       0             SPECIAL CHAR TESTS FOLLOW
           NE        B1,B5,GETQFC5 TEST FOR ASTERISK (QUAL DELIMITER)
           SB3       18
           SA6       A2            STORE QUALIFIER IN QFC(1)
           SB5       B0            DEFUSE QUAL DELIMITER TRAP
           NZ        X1,GETQFC1    RESUME SCAN FROM TOP IF (X1)NZ
           EQ        GETQFC6
GETQFC5    BSS       0
           NE        B1,B6,GETQFC7 ABANDON SCAN ON ANY SPEC CHAR BUT 1R(
           SA7       A7            STORE FILENAME IN QFC(2)
           SB6       B0            TURN OFF CYCLE DELIMITER TRAP
           NZ        X1,GETQFC1    RESUME SCAN FROM TOP IF (X1)NZ
GETQFC6    BSS       0
           SX5       X5+B7         INCREMENT EDN WORD COUNT
           SA1       A1+B7         LOAD NEXT EDN WORD IN (X1)
           NG        X5,GETQFC1    CONTINUE SCAN IF (X5) LT 0
*
GETQFC7   BSS       0              TERMINATION SECTION FOLLOWS
          EQ        B6,GETQFC8     TEST FOR NAME/CYCLE
          SA7       A7             STORE FILENAME IN QFC(2)
          EQ        IOMQFC         EXIT
GETQFC8   BSS       0              FILE CYCLE DECODING FOLLOWS
          BX7       X0*X6          (X7) = ENCODED LAST FC DIGIT
          AX6       6
          BX6       X0*X6          (X6) = ENCODED FIRST FC DIGIT IF ANY
          SB1       X6
          IX7       X7-X4          CONVERT FIRST DIGIT TO NUMERIC
          GT        B1,B4,GETQFC10
          IX6       X6-X4          CONVERT FIRST DIGIT TO NUMERIC
          SB1       X6
          LX6       3
          LE        B1,GETQFC10
          IX7       X6+X7
          SB1       B1+B1
          SX7       X7+B1          (X7) = DECODED FILE CYCLE
GETQFC10  BSS       0
          SA7       A7+B7          STORE FILE CYCLE IN QFC(3)
          EQ        IOMQFC         EXIT
LFNBF     SPACE     2
***       LFNBF     (LFN)
*
*         FUNCTION PROCEDURE TO BLANKFILL A LOGICAL FILE NAME WORD.
*
*         FORTRAN REFERENCE&
*
*         LFNB =    LFNBF (LFN)
*
*         WHERE LFN IS WORD HOLDING A ZERO-FILLED LFN STRING
*
*         COMPASS REFERENCE -
*
*         (X1) =    LFN
*         RJ        LFNBF$
*
*         THE RESULT RETURNS IN THE FUNCTION REGISTER (X6)
*         (B6),(B7) ARE SET TO 2,1 RESPECTIVELY.
*
*
          ENTRY     LFNBF,LFNBF$
LFNBF$    BSS       1              COMPASS-CALLABLE ENTRY POINT
          MX6       60D            (X6) = FULL WORD MASK
          SB6       7              (B6) = MAX. CHARS IN LFN
          BX2       X1             (X2) = INPUT LFN
          MX3       6              (X3) = CHAR EXTRACTION MASK
          SB7       1              (B7) = 1
LFNBF1     BSS       0
           BX1       X3*X2         ISOLATE CHARACTER IN (X1)
           ZR        X1,LFNBF2     EXIT LOOP ON ZERO BYTE
           BX6      -X3*X6         CLIP MASK
           SB6       B6-B7         DECREMENT COUNTER
           LX3       54D           ROTATE (X3) ONE CHAR RIGHT
           GT        B6,LFNBF1     CYCLE IF LESS THAN 7 CHARS PROCESSED
LFNBF2    BSS       0
          SA1       =10H           (X1) = BLANK WORD
          BX2       -X6*X2         CLEAR TRAILING GARBAGE
          SB6       B7+B7          (B6) = 2
          BX1       X6*X1          CLIP BLANKFILL
          BX6       X1+X2          FORM RESULT
          EQ        LFNBF$         RETURN
LFNBF     BSS       1              FORTRAN-CALLABLE ENTRY
          SA1       X1             (X1) = LFN                      (FTN)
          RJ        LFNBF$
          EQ        LFNBF
LFNINC    SPACE     2
***       LFNINC(LFN)
*
*         FUNCTION PROC TO INCREMENT LAST CHAR OF LOGICAL FILENAME
*
          ENTRY     LFNINC
LFNINC    BSS       1              ENTRY POINT
          SA1       X1             (X1) = LFN                      (FTN)
          SB7       1              (B7) = 1
          MX0       -6             (X0) = CHAR EXTRACTION MASK
          SB5       18
          SB6       54
          MX2       18
          AX1       18
          SX7       B7             (X7) = 1
          BX1       -X2*X1
LFNINC1    BSS       0
           BX2       -X0*X1        ISOLATE CHAR IN (X2)
           NZ        X2,LFNINC2    EXIT LOOP ON NONZERO BYTE
           SB5       B5+6          ADVANCE SHIFT COUNT
           AX1       6             NEXT CHAR INTO POSITION
           LT        B5,B6,LFNINC1 CYCLE
LFNINC2   BSS       0
          IX6       X1+X7          FORM RESULT IN (X6)
          LX6       B5,X6          LEFTJUSTIFY STRING
          EQ        LFNINC         RETURN
LFNZF     SPACE     2
***       LFNZF     (LFN)
*
*         FUNCTION PROCEDURE TO ZEROFILL A LFN STRING.  LAST 18
*         BITS ARE NOT MODIFIED.
*
*         FORTRAN REFERENCE -
*
*         LFNZ =    LFNZF (LFN)
*
*         WHERE LFN IS A WORD CONTAINING A LFN STRING DELIMITED
*         BY ZERO BYTE OR A SPECIAL CHARACTER (CODE GT 44B)
*
*         COMPASS REFERENCE -
*
*         (X1) =    LFN
*         RJ        LFNZF$
*
*         RESULT RETURNS IN THE FUNCTION REGISTER (X6)
*
*
*         REGISTERS USED BY LFNZF$& X0,X2,X3,B2,B3
*         (B6),(B7) SET TO 2,1, RESP., (B4) RESTORED.
*
          ENTRY     LFNZF,LFNZF$
LFNZF2    BSS       0
          BX6       -X6*X1         INJECT ZERO FILL
          SB6       B7+B7          (B6) = 2
          SB4       X3             RESTORE (B4)
LFNZF$    BSS       1              COMPASS-CALLABLE ENTRY
          SX3       B4
          MX0       6              (X0) = CHAR EXTRACTION MASK
          SB6       7              (B6) = MAX LFN CHARS
          SB4       B0
          MX6       42D            42-BIT MASK IN (X6)
          SB3       1R9            (B3) = 44B FOR SPECIAL CHAR TESTS
          SB7       1              (B7) = 1
LFNZF1     BSS       0
           BX2       X0*X1         ISOLATE CHAR IN (X2)
           SB4       B4+6          INCREMENT NOMINAL SHIFT COUNTER
           SB6       B6-B7         DECREMENT CHAR COUNTER
           LX2       B4,X2         RIGHTJUSTIFY CHARACTER
           SB2       X2            (B2) = CHAR TO TEST
           EQ        B2,LFNZF2     EXIT LOOP ON ZERO BYTE
           GT        B2,B3,LFNZF2  OR SPECIAL CHARACTER
           BX6       -X0*X6        ZERO WINDOW ON MASK WORD
           LX0       54D           ROTATE (X0) TO NEXT CHAR POSITION
           GT        B6,LFNZF1     CYCLE IF LESS THAN 7 CHARS PROCESSED
          EQ        LFNZF2
LFNZF     BSS       1              FORTRAN-CALLABLE ENTRY
          SA1       X1             (X1) = LFN                      (FTN)
          RJ        LFNZF$
          EQ        LFNZF
*
LJRJN     SPACE     2
***       LJRJN  (RJN)
*
*         TO LEFTJUSTIFY A RIGHTJUSTIFIED NAME STRING
*
*         FORTRAN REFERENCE -
*
*         NAME =    LJRJN (RJN)
*
*         WHERE
*
*         RJN       RIGHTJUSTIFIED TEXTSTRING WITH ZERO/BLANK FILL
*         LJRJN     LEFTJUSTIFIED NAME WITH SAME FILL TYPE
*
          ENTRY     LJRJN
LJRJN     BSS       1
          SA1       X1                                             (FTN)
          SB6       10
          MX2       -6
          SB3       1R9
          BX6       X1
          LX1       6
LJRJN1     BSS       0
           BX2       -X2*X1
           SB6       B6-1
           SB2       X2
           EQ        B2,LJRJN2
           LE        B2,B3,LJRJN
LJRJN2     LX1       6
           MX2       -6
           LX6       6
           GT        B6,LJRJN1
          EQ        LJRJN
LMXXXX    SPACE     2
***       LMDLOC (LDI)        LMEQPC(LDI)         LMIFNM(LDI)
***       LMLIMT (LDI)        LMNEXT(LDI)         LMSECT(LDI)
***       LMUNIT (LDI)
*
*         USER-PROGRAM CALLABLE ENTRIES TO RETRIEVE AST
*         DATA PERTAINING TO A LOGICAL DEVICE INDEX (LDI)
*
*         FORTRAN REFERENCE -
*         INF =     LM XXXX (LDI)
*
*         WHERE  XXXX = EQPC, DLOC, NEXT, SECT, UNIT  TO RETRIEVE
*         EQUIPMENT CODE, CURRENT DEVICE LOCATION, NEXT FREE
*         LOCATION, SECTOR SIZE, AND UNIT NUMBER, RESPECTIVELY,
*         ASSOCIATED WITH THE LOGICAL DEVICE INDEX LDI.
*
*         NOTE -  ONLY LMSECT TESTS FOR LEGAL LDI RANGE.
*
          ENTRY     LMEQPC,LMDLOC,LMIFNM,LMLIMT,LMNEXT,LMSECT,LMUNIT
LMEQPC    BSS       1
          SA1       X1             (X1) = LDI                      (FTN)
          SB1       X1
          SA1       ASTEQC-1+B1
          BX6       X1             (X6) = ASTEQC(LDI)
          EQ        LMEQPC
LMDLOC    BSS       1
          SA1       X1             (X1) = LDI                      (FTN)
          SB1       X1
          SA1       ASTLOC-1+B1
          BX6       X1             (X6) = ASTLOC(LDI)
          EQ        LMDLOC
LMIFNM    BSS       1
          SA1       X1             (X1) = LDI                      (FTN)
          SB1       X1
          SA1       ASTLFN-1+B1
          RJ        LFNBF$         BLANKFILL LFN
          EQ        LMIFNM
LMNEXT    BSS       1
          SA1       X1             (X1) = LDI                      (FTN)
          SB1       X1
          SA1       ASTNXT-1+B1
          BX6       X1             (X6) = ASTNXT(LDI)
          EQ        LMNEXT
LMLIMT    BSS       1
          SA1       X1             (X1) = LDI                      (FTN)
          SB1       X1
          SA1       ASTLIM-1+B1
          BX6       X1             (X6) = ASTLIM(LDI)
          EQ        LMLIMT
LMSECT    BSS       1
          SA1       X1             (X1) = LDI                      (FTN)
          SB6       MAXLDI         (B6) = LARGEST ALLOWED LDI
          SB1       X1             (B1) = LDI
          SX6       -1             (X6) = -1
          LE        B1,LMSECT      RETURN (X6)=-1  IF LDI LE 0
          GT        B1,B6,LMSECT   RETURN (X6)=-1  IF LDI GT 16
          SA2       ASTEQC-1+B1    (X2) = ASTEQC(LDI)
          SA3       ASTYPE-1+B1    (X3) = ASTYPE(LDI) = TYPEX+4
          ZR        X2,LMSECT      RETURN (X6)=-1  IF LDI IS INACTIVE
          MX0       -3             (X0) = 57-BIT MASK
          BX3       -X0*X3         (X3) = TYPEX+4 IN RANGE (0,7)
          SA1       ASTSEC+X3      (X1) = ASTSEC(TYPEX+5)
          BX6       X1             (X6) = SECTOR SIZE
          EQ        LMSECT         RETURN TO CALLING PROGRAM
LMUNIT    BSS       1
          SA1       X1             (X1) = LDI                      (FTN)
          SB1       X1
          SA1       ASTUNT-1+B1
          BX6       X1             (X6) = ASTUNT(LDI)
          EQ        LMUNIT
*
NCOCTL$   SPACE     2
***       NCOCTL$
*
*         TO CONVERT A 1-9 DIGIT POSITIVE INTEGER TO OCTAL
*         DISPLAY CODE FORMAT
*
*         COMPASS REFERENCE -
*
*         (X1) =    INTEGER TO BE ENCODED
*         RJ        NCOCTL$
*
*         THE RESULT RETURNS IN (X6)
*
*         REGISTERS USED&   A1,X1,X2,X3,X6
*         EXIT (B6)=2, (B7)=1
*
          ENTRY     NCOCTL$
NCOCTL$   BSS       1              ENTRY/EXIT
          MX2       -27D
          SB6       B0             INITIALIZE BIT COUNTER
          BX2       -X2*X1         LIMIT INTEGER TO 9 OCTAL DIGITS
          MX3       -6             (X3) = RJ CHAR MASK
          SA1       =10H         B
          SB7       6              (B7) = 6
NCOCTL1    BSS       0
           MX6       -3            (X6) = OCTAL DIGIT MASK
           SB6       B6+B7         ADVANCE BIT COUNT BY 6
           BX6       -X6*X2        ISOLATE OCTAL DIGIT IN (X6)
           LX3       6             POSITION CHAR MASK
           SX6       X6+1R0        OCTAL DIGIT TO DISPLAY CODE
           BX1       X3*X1         CARVE CHAR WINDOW IN (X1)
           LX6       B6,X6         ROTATE ENCODED DIGIT CHAR
           AX2       3             ALIGN NEXT DIGIT OF SOURCE WORD
           BX1       X1+X6         STUFF ENCODED DIGIT IN RESULT WORD
           NZ        X2,NCOCTL1    CONTINUE IF SOURCE WORD IS NZ
          SB7       1              RESTORE (B7) = 1
          BX6       X1             PUT RESULT IN (X6)
          SB6       B7+B7          RESTORE (B6) = 2
          EQ        NCOCTL$        EXIT
RFNBF     SPACE     2
***       RFNBF (RFN)
*
*         INJECT BLANKFILL IN A ZEROFILLED RIGHTJUSTIFIED FILENAME
*
*         FORTRAN REFERENCE -
*
*         RFNB =    RFNBF (RFN)
*         WHERE
*
*         RFN       ZERO-FILLED RIGHTJUSTIFIED CHAR STRING
*         RFNBF     SAME AS RFN, WITH 0-FILL REPLACED BY BLANKFILL
*
*         COMPASS REFERENCE -
*
*         (X1) =    LFN
*         RJ        RFNBF$
*
*         THE RESULT RETURNS IN (X6)
*         REGISTERS DESTROYED BY RFNBF$& B6,X1,X2,X3,X4,X6
*
*
          ENTRY     RFNBF,RFNBF$
RFNBF$    BSS       1              COMPASS-CALLABLE ENTRY POINT
          BX6       X1             INITIALIZE RESULT REGISTER
          MX1       6              (X1) = LJ CHAR MASK
          SX3       1R             (X3) = FILL CHAR
          SB6       10             MAX CHARS IN STRING
          SB7       1              (B7) = 1
RFNBF1     BSS       0
           BX2       X1*X6         EXTRACT CHARACTER
           LX1       54D           ROTATE MASK
           NZ        X2,RFNBF$     EXIT ON NONZERO BYTE
           LX3       54D
           SB6       B6-B7         DECREMENT MAX CHAR COUNTER
           BX6       X3+X6         INSERT BLANK CHARACTER
           GT        B6,RFNBF1     CYCLE
          EQ        RFNBF$         RETURN
RFNBF     BSS       1              FORTRAN CALLABLE ENTRY
          SA1       X1             (X1) = LFN                      (FTN)
          RJ        RFNBF$
          EQ        RFNBF
*
          END
*DECK       IOMPFM
* =DECK      IOMPFM      IOMPFM      ASSEMBLY
          IDENT     IOMPFM
          TITLE     PERMANENT FILE MANAGEMENT FUNCTIONS
ASMCNTL   SPACE     3
*CALL       IOMACTL
          IFEQ      OS,NOS         *
************************************                               (NOS)
*    EXTERNAL TEXT COMMON DECKS    *                               (NOS)
************************************                               (NOS)
*         LIST      X              *                               (NOS)
          XTEXT     COMCSYS        *  SYSTEM REQUEST ROUTINES      (NOS)
          XTEXT     COMCPFM        *                               (NOS)
          ENDIF                    *
************************************
COMMON    SPACE     2
***       COMMON BLOCK DECLARATION
*
* =PROCEDURE CDMASTA
*CALL        CDMASTA
          USE       0
SUMMARY   SPACE     3
************************************************************************
*                                                                      *
*         PERMANENT FILE FUNCTIONS PROVIDE FOR RUNTIME EXECUTION       *
*         OF BASIC OPERATIONS PERTAINING TO THE ACTIVITY/STATUS        *
*         OF DATA FILES RESIDING ON PERMANENT DEVICES.                 *
*                                                                      *
*         PROGRAMMED BY C.A. FELIPPA, DEC 1975                         *
*                                                                      *
*         UPDATE -  NOV 1977                                           *
*                                                                      *
************************************************************************
*                                                                      *
*         A SUMMARY DESCRIPTION FOLLOWS.                               *
*                                                                      *
*         IOMAPF    ATTACH PERMANENT FILE TO JOB  (SCOPE/NOS)          *
*                                                                      *
*         IOMCPF    CATALOG PERMANENT FILE (SCOPE)                     *
*                                                                      *
*         IOMDPF    DEFINE DIRECT-ACCESS PERMANENT FILE (NOS)          *
*                                                                      *
*         IOMEPF    EXTEND PERMANENT FILE (SCOPE)                      *
*                                                                      *
*         IOMPPF    PURGES PERMANENT FILE (SCOPE/NOS)                  *
*                                                                      *
*         IOMRPF    REQUESTS EQUIPMENT APPROPRIATE AS RESIDENCE        *
*                   MEDIUM FOR A  PERMANENT FILE (SCOPE)               *
*                                                                      *
************************************************************************
IOMAPF    SPACE     2
***       IOMAPF    (LFN, PFN, ID, MR)                           (SCOPE)
***       IOMAPF    (LFN, PFN, UN, M)                              (NOS)
*
*         ENTRY POINT TO ATTACH A PERMANENT FILE TO RUN
*
*         FORTRAN REFERENCE (SCOPE) -
*
*         CALL   IOMAPF  (LFN, PFN, ID, M)
*
*         WHERE
*
*         LFN       LOGICAL FILENAME
*
*         PFN       42/PFN,6/0,6/RP,6/CY, AS IN IOMCPF.
*
*         ID        OPTIONAL OWNERS ID, AS IN IOMCPF.
*
*         M         FILE ACCESS MODE PARAMETER
*                    -1   MULTIREAD ACCESS (SAME AS MR=1 ON CC)
*                    +1   EXCLUSIVE ACCESS (SAME AS RW=0 ON CC)
*                     0   THIS ARGUMENT IS IGNORED
*
*         FORTRAN REFERENCE (NOS) -
*
*         CALL   IOMAPF  (LFN, PFN, UN, M)
*
*         WHERE
*
*         LFN,PFN   SAME AS ABOVE.  HOWEVER, RP AND CY FIELDS IN
*                   PFN WORD ARE IGNORED.
*
*         UN        OPTIONAL USERS NUMBER OR ID.  IF ZERO, THIS
*                   PARAMETER IS IGNORED.
*
*         M         FILE ACCESS MODE, AS IN IOMDPF.
*
          ENTRY     IOMAPF
IOMAPF    BSS       1              ENTRY/EXIT POINT
APFSYST   IFEQ      OS,SCOPE
          SB5       -1             MARK ATTACH ENTRY             (SCOPE)
          RJ        FDBSET         INITIALIZE FILE DEF BLOCK     (SCOPE)
          SX7       11B                                          (SCOPE)
          ZR        X4,ATTPF1                                    (SCOPE)
          SX7       033B           SET EXCLUSIVE ACCESS          (SCOPE)
          PL        X4,ATTPF1      TEST FOR M=1                  (SCOPE)
          SX7       111B           SET MULTIREAD ACCESS FLAG     (SCOPE)
ATTPF1    BSS       0                                            (SCOPE)
          SA7       A7+B7          STORE ACCESS MODE DESCRIPTOR  (SCOPE)
+         SA5       =7HATTACH,                                   (SCOPE)
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE     (SCOPE)
          ATTACH    FDB,RC         ATTACH MACRO                  (SCOPE)
+         SA2       IOMAPF         FETCH RETURN INSTRUCTION      (SCOPE)
          EQ        PFMEXIT        GET RETURN CODE AND EXIT      (SCOPE)
APFSYST   ELSE
          SB5       -1             MARK ATTACH ENTRY               (NOS)
          RJ        PFMFET         INITIALIZE FET FOR PFM REQUESTS (NOS)
          MX6       0                                              (NOS)
          BX7       X4             (X7) = M                        (NOS)
          SA6       UNW            CLEAR UN                        (NOS)
          SA7       AMW            STORE M                         (NOS)
          ZR        X3,ATTPF3                                      (NOS)
          BX6       X3                                             (NOS)
          BX1       X3             (X6) = UN                       (NOS)
          SA6       RJUNW                                          (NOS)
          SX1       A6                                             (NOS)
          RJ        =XLJRJN                                        (NOS)
          SA6       UNW                                            (NOS)
          SB1       RJUNW                                          (NOS)
ATTPF3    BSS       0
+         SA5       =7HATTACH,                                     (NOS)
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE       (NOS)
          ATTACH    FET,,UNW,,AMW  ATTACH MACRO                    (NOS)
+         SA2       IOMAPF         FETCH RETURN INSTRUCTION        (NOS)
          EQ        PFMEXIT        GET RETURN CODE AND EXIT        (NOS)
APFSYST   ENDIF
IOMCPF    SPACE     2
***       IOMCPF  (LFN, PFN, ID, XR)                             (SCOPE)
*
*         ENTRY POINT TO CATALOG A PERMANENT FILE (SCOPE ONLY)
*
*         FORTRAN REFERENCE -
*
*         CALL   IOMCPF  (LFN, PFN, ID, XR)
*
*         WHERE
*
*         LFN       LOGICAL FILENAME (1-7 ALPHANUMERIC CHARS,
*                   LEFTJUSTIFIED, ZEROFILLED). MUST BE
*                   CURRENTLY ATTACHED TO JOB.
*
*         PFN       42/PFN,6/0,6/RP,6/CY      WHERE
*                   PFN    PERMANENT FILENAME (SAME RESTRICTIONS
*                          AS FOR LFN)
*                   CY     CYCLE NUMBER (1-63). IF ZERO, THE O/S
*                          WILL ASSUME CY = (HIGHEST CAT CY) + 1
*                   RP     RETENTION PERIOD IN DAYS.  IF 0, THE
*                          PROGRAM ASSUMES RP=30 DAYS.
*
*         ID        OPTIONAL OWNERS ID (1 TO 7 CHARS, RJ WITH
*                   ZERO FILL).  IF ZERO, THIS SPEC IS IGNORED.
*
*         XR        IF NONZERO, PROGRAM ASSUMES THAT THIS IS A
*                   CONTROL/MODIFY/EXTEND PASSWORD (1-7 CHARS,
*                   RIGHTJUSTIFIED W/ZERO FILL). IGNORED IF ZERO
*
          ENTRY     IOMCPF
IOMCPF    BSS       1              ENTRY/EXIT POINT
CPFSYST   IFEQ      OS,SCOPE
          SB5       1              MARK CATALOG ENTRY            (SCOPE)
          RJ        FDBSET         INITIALIZE FILE DEF BLOCK     (SCOPE)
          SX2       13B            (X2) = CODE FOR XR DESCRIPTOR (SCOPE)
          BX4       -X0*X4         (X4) = MASKED XR STRING       (SCOPE)
          LX4       6              ROTATE XR                     (SCOPE)
          ZR        X4,CATPF1      OMIT XR SPEC IF XR=0          (SCOPE)
          BX7       X4+X2          FORM DESCRIPTOR IN (X7)       (SCOPE)
          SA7       A7+B7          STORE XR SPEC                 (SCOPE)
CATPF1    BSS       0                                            (SCOPE)
+         SA5       =9HCATALOG,                                  (SCOPE)
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE     (SCOPE)
          CATALOG   FDB,RC         CATALOG MACRO                 (SCOPE)
+         SA2       IOMCPF         FETCH RETURN INSTRUCTION      (SCOPE)
          EQ        PFMEXIT        GET RETURN CODE AND EXIT      (SCOPE)
CPFSYST   ELSE
          EQ        IOMCPF                                         (NOS)
CPFSYST   ENDIF
IOMDPF    SPACE     2
***       IOMDPF   (LFN, PFN, CT, M)                               (NOS)
*
*         ENTRY POINT TO DEFINE A (DIRECT ACCESS) PERMANENT FILE.
*         (NOS SYSTEM ONLY)
*
*         FORTRAN REFERENCE -
*
*         CALL   IOMDPF  (LFN, PFN, CT, M)
*
*         WHERE
*
*         LFN       LOGICAL FILENAME, AS IN IOMCPF.
*
*         PFN       42/PFN,6/0,6/RP,6/CY.  CY,RP ARE IGNORED UNDER NOS.
*
*         CT        FILE CATEGORY OCTAL VALUE (CF. NOS MANUAL)
*
*         M         FILE ACCESS MODE OR PERMISSION LEVEL
*                   OCTAL VALUE (CF. NOS MANUAL)
*
          ENTRY     IOMDPF
IOMDPF    BSSZ      1              ENTRY/EXIT POINT
DPFSYST   IFEQ      OS,SCOPE
          EQ        IOMDPF                                       (SCOPE)
DPFSYST   ELSE
          SB5       1              MARK DEFINE ENTRY               (NOS)
          RJ        PFMFET         INITIALIZE FET FOR PFM REQUESTS (NOS)
          BX6       X3             (X6) = CT                       (NOS)
          LX7       X4             (X7) = M                        (NOS)
          SA6       CTW            STORE CT                        (NOS)
          SA7       AMW            STORE M                         (NOS)
+         SA5       =7HDEFINE,     (X5) = OPERATION ID             (NOS)
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE       (NOS)
          DEFINE    FET,,,,,CTW,AMW                                (NOS)
+         SA2       IOMDPF         FETCH RETURN INSTRUCTION        (NOS)
          EQ        PFMEXIT        GET RETURN CODE AND EXIT        (NOS)
DPFSYST   ENDIF
*
IOMEPF    SPACE     2
***       IOMEPF    (LFN, PFN, ID, 0)
*
*         ENTRY POINT TO EXTEND A PERMANENT FILE  (SCOPE ONLY)
*
*         FORTRAN REFERENCE -
*
*         CALL   IOMEPF  (LFN, PFN, ID, 0)
*
*         WHERE
*
*         LFN,PFN,ID     SAME AS FOR IOMCPF/IOMAPF
*
          ENTRY     IOMEPF
IOMEPF    BSS       1              ENTRY/EXIT POINT
EPFSYST   IFEQ      OS,SCOPE
          SB5       B0             MARK EXTEND/PURGE ENTRY       (SCOPE)
          RJ        FDBSET         INITIALIZE FILE DEF BLOCK     (SCOPE)
+         SA5       =7HEXTEND,     (X5) = OPER ID                (SCOPE)
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE     (SCOPE)
          EXTEND    FDB,RC         EXTEND MACRO                  (SCOPE)
          SA2       IOMEPF         FETCH RETURN INSTRUCTION      (SCOPE)
          EQ        PFMEXIT        GET RETURN CODE AND EXIT      (SCOPE)
EPFSYST   ELSE
          EQ        IOMEPF                                         (NOS)
EPFSYST   ENDIF
*
IOMPPF    SPACE     2
***       IOMPPF    (LFN, PFN, ID, 0)                            (SCOPE)
***       IOMPPF    (LFN, PFN, UN, PW)                             (NOS)
*
*         ENTRY POINT TO PURGE AN ATTACHED PERMANENT FILE
*
*         FORTRAN REFERENCE (SCOPE) -
*
*         CALL   IOMPPF  (LFN, PFN, ID, 0)
*
*         WHERE
*
*         LFN,PFN,ID     SAME AS FOR IOMCPF/IOMAPF
*                   LFN MUST BE CURRENTLY ATTACHED TO JOB.
*
*         FORTRAN REFERENCE (NOS) -
*         CALL   IOMPPF  (LFN, PFN, UN, 0)
*
*         WHERE
*
*         LFN,PFN   SAME AS ABOVE
*         UN        USERS NUMBER
*
          ENTRY     IOMPPF
IOMPPF    BSS       1              ENTRY/EXIT POINT
PPFSYST   IFEQ      OS,SCOPE
          SB5       B0             MARK EXTEND/PURGE ENTRY       (SCOPE)
          RJ        FDBSET         INITIALIZE FILE DEF BLOCK     (SCOPE)
+         SA5       =6HPURGE,      (X5) = OPER ID                (SCOPE)
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE     (SCOPE)
          PURGE     FDB,RC         PURGE MACRO                   (SCOPE)
          SA2       IOMPPF         FETCH RETURN INSTRUCTION      (SCOPE)
          EQ        PFMEXIT        GET RETURN CODE AND EXIT      (SCOPE)
PPFSYST   ELSE
          RJ        PFMFET         INITIALIZE FET FOR PFM REQUESTS (NOS)
+         SA5       =6HPURGE,      (X5) = OPER ID                  (NOS)
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE       (NOS)
          PURGE     FET                                            (NOS)
          SA2       IOMPPF         FETCH RETURN INSTRUCTION        (NOS)
          EQ        PFMEXIT        GET RETURN CODE AND EXIT        (NOS)
PPFSYST   ENDIF
*
IOMRPF    SPACE      2
***       IOMRPF    (LFN)
*
*         ENTRY POINT TO REQUEST EQUIPMENT APPROPRIATE TO
*         PERMANENT FILE (SCOPE ONLY)
*
*         FORTRAN REFERENCE -
*
*         CALL   IOMRPF  (LFN)
*
*         WHERE LFN IS THE LOGICAL FILENAME OF THE PERM FILE.
*
          ENTRY     IOMRPF
IOMRPF    BSS       1
RPFSYST   IFEQ      OS,SCOPE
          SB7       1                                            (SCOPE)
          MX7       0                                            (SCOPE)
          SA1       X1             (X1) = LFN                    (SCOPE)
          SA7       FET+8          CLEAR FET(9)                  (SCOPE)
          MX0       42D                                          (SCOPE)
          SA7       A7-B7          CLEAR FET(8)                  (SCOPE)
          SB1       B0                                           (SCOPE)
          SA7       A7-B7          CLEAR FET(7)                  (SCOPE)
          SB2       B0                                           (SCOPE)
          SA7       A7-B7          CLEAR FET(6)                  (SCOPE)
          SA3       REQPFW         (X3) = *PF REQUEST WORD       (SCOPE)
          SA7       A7-B7          CLEAR FET(5)                  (SCOPE)
          SB3       B0                                           (SCOPE)
          SA7       A7-B7          CLEAR FET(4)                  (SCOPE)
          SA2       =3L*PF         (A2) = ADDRESS(DUMMY PFN)     (SCOPE)
          BX6       X0*X1          (X6) = MASKED LFN             (SCOPE)
          SA7       A7-B7          CLEAR FET(3)                  (SCOPE)
          BX7       X3             (X7) = FLAG WORD              (SCOPE)
          SA7       A7-B7          SET FET(2)                    (SCOPE)
          SA6       A7-B7          SET FET(1)                    (SCOPE)
          SA5       =8HREQUEST,    (X5) = OPERATION ID           (SCOPE)
          RJ        PFMESG                                       (SCOPE)
          REQUEST   FET            ISSUE REQUEST                 (SCOPE)
          SA2       IOMRPF         GET RETURN INSTRUCTION        (SCOPE)
          EQ        RPFEXIT        GET RETURN CODE AND EXIT      (SCOPE)
REQPFW    VFD       29/1,3/1,28/0            REQUEST,LFN,*PF     (SCOPE)
RPFSYST   ELSE
          EQ        IOMRPF                                         (NOS)
RPFSYST   ENDIF
FDBSET    SPACE     2
*
**        UTILITY CODE BLOCK TO INITIALIZE FILE DEFINITION BLOCK
*
*         ENTRY -   (B5) = FUNCTION FLAG&  1=CATALOG/DEFINE,
*                   -1=ATTACH, 0=EXTEND/PURGE.
*         EXIT -    (B7)=1, (B6)=2, LFN/PFN STORED,
*                   (A1)=ADDRESS(LFN), (A2)=ADDRESS(PFN),
*                   (A7) = ADDRESS OF LAST PARAMETER STORED,
*                   (X3) = VALUE OF 3RD ARGUMENT.
*                   (X4) = VALUE OF 4TH ARGUMENT.
*                   (B1)/(B2)/(B3)  ADRRESSES OF ID/CY/RP DESCR
*                   WORDS, RESP., IF IN FDB, ELSE ZERO.
*                   (X0) = 18-BIT MASK
*
FDBPFN    EQU       FET            PFN (SCOPE)
FDB       EQU       FET+4          LFN/RETURN-CODE/REQUEST-CODE (SCOPE)
PFMFET    BSS       0
FDBSET    BSS       1
FDBSYST   IFEQ      OS,SCOPE
          SA5       =55555555555555550000B                       (SCOPE)
          SB7       1              (B7) = 1                      (SCOPE)
          MX6       0              (X6) = 0                      (SCOPE)
          BX7       X5             (X7) = TERMINATOR WORD        (SCOPE)
          SA6       FDB-1                                        (SCOPE)
          SB6       B7+B7          (B6) = 2                      (SCOPE)
          SA7       A6+B6                                        (SCOPE)
          SA6       A6-B7                                        (SCOPE)
          SA7       A7+B7                                        (SCOPE)
          SA6       A6-B7                                        (SCOPE)
          SA7       A7+B7                                        (SCOPE)
          MX0       42D            (X0) = FILENAME MASK          (SCOPE)
          SA7       A7+B7                                        (SCOPE)
          SA7       A7+B7                                        (SCOPE)
          SA2       A1+B7                                          (FTN)
          SA3       A1+B6                                          (FTN)
          SA4       A2+B6                                          (FTN)
          SA1       X1             (X1) = LFN                      (FTN)
          SA2       X2             (X2) = PFN                      (FTN)
          SA3       X3             (X3) = ID                       (FTN)
          SA4       X4             (X4) = 4TH ARG VALUE            (FTN)
          BX7       X0*X1          (X7) = MASKED LFN             (SCOPE)
          BX6       X0*X2          (X6) = MASKED PFN             (SCOPE)
          SA7       FDB            STORE LFN                     (SCOPE)
          SA6       A6-B7          STORE PFN                     (SCOPE)
          BX5      -X0*X2          (X5) = RP/CY FIELDS           (SCOPE)
          MX0       -48D                                         (SCOPE)
          SB1       B0             (B1) = 0                      (SCOPE)
          BX3       -X0*X3         LIMIT ID TO 8 CHARACTERS      (SCOPE)
          SX7       14B            (X7) = CODE FOR ID-WORD       (SCOPE)
          LX3       6              ROTATE ID STRING              (SCOPE)
          SA1       A7             (A1) = ADDRESS(LFN) IN FDB    (SCOPE)
          SA2       A6             (A2) = ADDRESS(PFN) IN FDB    (SCOPE)
          ZR        X3,FDBSET1     OMIT ID SPEC IF ID=0          (SCOPE)
          BX7       X3+X7          INSERT ID CODE                (SCOPE)
          SA7       A7+B7          STORE ID SPEC                 (SCOPE)
          SB1       A7             (B1) = ADDRESS(ID-DESCRIPTOR) (SCOPE)
FDBSET1   BSS       0                                            (SCOPE)
          MX0       -6                                           (SCOPE)
          BX7       -X0*X5         (X7) = CY FIELD               (SCOPE)
          SB2       B0             (B2) = 0                      (SCOPE)
          LX7       6              POSITION CY VALUE             (SCOPE)
          EQ        B5,FDBSET2     IGNORE CY ON EXTEND/PURGE     (SCOPE)
          ZR        X7,FDBSET2     OR IF CY = 0                  (SCOPE)
          SX7       X7+3           INSERT CY IDENTIFIER  (03B)   (SCOPE)
          SA7       A7+B7          STORE CYCLE DESCRIPTOR WORD   (SCOPE)
          SB2       A7             (B2) = ADDRESS(CY-DESCRIPTOR) (SCOPE)
FDBSET2   BSS       0                                            (SCOPE)
          AX5       6              RIGHTJUSTIFY RP FIELD         (SCOPE)
          BX7       -X0*X5         (X7) = RP                     (SCOPE)
          SB3       B0             (B3) = 0                      (SCOPE)
          LX7       6                                            (SCOPE)
          LE        B5,FDBSET4     IGNORE RP EXCEPT FOR CATALOG  (SCOPE)
          NZ        X7,FDBSET3     TEST FOR NONZERO RP           (SCOPE)
          SX7       3600B          IF RP=0, SET RP = 30 DAYS     (SCOPE)
FDBSET3   BSS       0                                            (SCOPE)
          SX7       X7+2           INSERT RP IDENTIFIER (02B)    (SCOPE)
          SA7       A7+B7          STORE RP DESCRIPTOR           (SCOPE)
          SB3       A7             (B3) = ADDRESS(RP-DESCRIPTOR) (SCOPE)
FDBSET4   BSS       0                                            (SCOPE)
          MX0       -42D                                         (SCOPE)
FDBSYST   ELSE
          MX6       0              (X6) = 0                        (NOS)
          SB7       1              (B7) = 1                        (NOS)
          MX7       0              (X7) = 0                        (NOS)
          SB6       B7+B7          (B6) = 2                        (NOS)
          SA6       FET+1          CLEAR FET(2)                    (NOS)
          SA7       A6+B7          CLEAR FET(3)                    (NOS)
          SA6       A6+B6          CLEAR FET(4)                    (NOS)
          SA7       A7+B6          CLEAR FET(5)                    (NOS)
          SA6       A6+B6          CLEAR FET(6)                    (NOS)
          SA7       A7+B6          CLEAR FET(7)                    (NOS)
          SA6       A6+B6          CLEAR FET(8)                    (NOS)
          MX0       42D                                            (NOS)
          SA2       A1+B7                                          (FTN)
          SA1       X1             (X1) = LFN                      (FTN)
          SA3       A2+B7                                          (FTN)
          SA2       X2             (X2) = PFN                      (FTN)
          SA4       A3+B7                                          (FTN)
          SA3       X3             (X3) = 3RD ARGUMENT             (FTN)
          SA4       X4             (X4) = 4TH ARGUMENT             (FTN)
          BX7       X0*X1          (X7) = MASKED LFN               (NOS)
          BX6       X0*X2          (X6) = MASKED PFN               (NOS)
          SX5       B7                                             (NOS)
          SB1       B0             (B1) = 0                        (NOS)
          BX7       X5+X7          SET FET ACTIVITY BIT ON         (NOS)
          SA1       FETW1                                          (NOS)
          SA7       FET            STORE LFN                       (NOS)
          SA6       FET+8          STORE PFN                       (NOS)
          BX6       X1                                             (NOS)
          SA6       A7+B7          STORE FET+1                     (NOS)
          EQ        PFMFET         RETURN TO APPROPRIATE PROCEDURE (NOS)
FETW1     VFD       15/0,1/1,20/0,6/7,18/0     EP=1, FETLGTH=5+7   (NOS)
FDBSYST   ENDIF
          EQ        FDBSET         RETURN TO APPROPRIATE ENTRY
PFMESG    SPACE     2
*
**        CODE BLOCK TO GENERATE AND PRINT INFORMATIVE MESSAGE
*
*         ENTRY REGISTER SET -
*         (A1)=ADDRESS(LFN), (A2)=ADDRESS(PFN)
*         (B1),(B2),(B3),(B7) -  SEE FDBSET
*         (X5) = OPERATION ID TEXT.
*         EXIT -    (B1)=1, ALL OTHERS DESTROYED.
*
PFMESG    BSS       1
          SA4       =6H0+++
          IFEQ      OS,SCOPE
          SA1       A1             (X1) = LFN                    (SCOPE)
          ELSE
          SA1       FET            (X1) = LFN                      (NOS)
          ENDIF
          LX7       X5
          BX6       X4
          SA7       ASTMSG+1       OPERATION ID TO ASTMSG(2)
          SA6       A7-B7          INITIALIZE ASTMSG(1)
          SX4       1R,
          RJ        =XLFNBF$       BLANKFILL LFN IN (X6)
          MX0       6
          LX4       12D
          LX0       18D
          BX7       -X0*X6
          IFEQ      OS,SCOPE
          SA1       A2             (X1) = PFN                    (SCOPE)
          ELSE
          SA1       FET+8          (X1) = PFN                      (NOS)
          ENDIF
          BX7       X4+X7          INSERT COMMA AFTER LFN
          RJ        =XLFNBF$       BLANKFILL PFN IN (X6)
          SA7       A7+B7          STORE LFN IN ASTMSG(3)
          BX7       X6             (X7) = PFN
          MX0       -6
          SA7       A7+B7          STORE PFN IN ASTMSG(4)
          EQ        B1,PFMSG1      SKIP IF NO ID STORED
          SX4       1R*
          SA1       B1             (X1) = ID DESCRIPTOR WORD
          RJ        =XRFNBF$       BLANKFILL PFN-ID IN (X6)
          MX0       -6
          BX6       X0*X6          CLEAR SLOT FOR *
          BX6       X6+X4          INSERT ASTERISK
          SA6       A7             STORE PFN-ID IN ASTMSG(4)
          SA7       A7+B7          STORE PFN INTO  ASTMSG(5)
PFMSG1    BSS       0
          IFEQ      OS,SCOPE
          EQ        B2,PFMSG2      OMIT CY PRINT IF (B2)=0
          SA1       B2             (X1) = CY DESCRIPTOR WORD
          AX1       6              RIGHTJUSTIFY CYCLE NO.
          SA5       =7L,  CY=
          RJ        =XNCOCTL$      CONVERT TO DISPLAY CODE IN (X6)
          MX0       -18D
          BX6       -X0*X6
          BX7       X5+X6          (X7) NOW HAS 10H,  CY = XXB
          SA7       A7+B7          STORE CY LABEL WORD
PFMSG2    BSS       0
          EQ        B3,PFMSG3      OMIT RP PRINT IF (B3)=0
          SA1       B3             (X1) = RP DESCRIPTOR WORD
          AX1       6              RIGHTJUSTIFY RP VALUE
          SA5       =7L,  RP=
          RJ        =XNCOCTL$      CONVERT TO DISPLAY CODE IN (X6)
          MX0       -18D
          BX6       -X0*X6
          BX7       X5+X6          (X7) NOW HAS 10H,  RP = XXB
          SA7       A7+B7          STORE RP LABEL WORD
PFMSG3    BSS       0
          ENDIF
          RJ        =XIOMESSG      PRINT MESSAGE
          SB1       1              SET (B1) = 1
          EQ        PFMESG         RETURN TO APPROPRIATE MACRO
*
*
**        UTILITY CODE BLOCK FOR TERMINATION ACTIVITIES
*
*         ENTRY -   (X2) = RETURN INSTRUCTION
*
RPFEXIT   BSS       0
          SA5       FET
          EQ        PFMEXIT+1
PFMEXIT   BSS       0
          IFEQ      OS,SCOPE
          SA5       FDB            FETCH BASE WORD               (SCOPE)
          ELSE
          SA5       FET            FETCH BASE WORD                 (NOS)
          ENDIF
+         BX7       X2
          MX0       -9D
          SA7       PFMRET         STORE RETURN
          AX5       9D
          BX6       -X0*X5         ISOLATE RETURN CODE
          SA6       STATUS         PLACE RC IN STATUS WORD
          ZR        X6,PFMRET      RETURN IF RC = 0
          SA5       =10HFAC STATUS
          LX1       X6
          BX7       X5
          SA7       ASTMSG+1
          RJ        =XNCOCTL$      ENCODE STATUS IN (X6)
          SA6       ASTMSG+2       STORE IT
          RJ        =XIOMESSG      PRINT STATUS MESSAGE
PFMRET    BSS       1              RETURN TO CALLING PROGRAM
*
          IFEQ      OS,NOS
CTW       BSSZ      1              FILE CATEGORY WORD              (NOS)
UNW       BSSZ      1              USERS NUMBER WORD               (NOS)
RJUNW     BSSZ      1                                              (NOS)
AMW       BSSZ      1              ACCESS MODE WORD                (NOS)
          ENDIF
          END
*DECK       IOMPRT
C=DECK      IOMPRT      IOMPRT      SUBROUTINE
      SUBROUTINE    IOM PRT
C
C=PURPOSE   COLLECTION OF DISPLAY PROCEDURES SUPPORTING DMGASP/CDC
C=AUTHOR    C. A. FELIPPA
C=VERSION   JUNE 1977
C=EQUIPMENT CDC
C=KEYWORDS  AUXILIARY   STORAGE     MANAGER     I/O         DATA
C=KEYWORDS  PRINT       DISPLAY     OUTPUT
C=EASY-SUB  LFNBF
C
C
C                   C O M M O N
C
C=PROCEDURE IOMCOM      CDMERR      CDMETS
*CALL               IOMCOM
*CALL               DMECOM
      COMMON /CDMPAD/
     $    CMSIZ,    BCSIZ,    REQCM,    LWAREC,   PAD(192)
      INTEGER       CMSIZ,    BCSIZ,    REQCM,    PAD
C
C                   T Y P E   A N D   D I M E N S I O N
C
      INTEGER       DEVDAT(12),EQCODE,  FET(12)
      INTEGER       ERRMSG(2,12)
      INTEGER       PFNDAT(3),TABFMT(7)
C
C                   E Q U I V A L E N C E
C
      EQUIVALENCE   (FET,ASTPKT(14))
      EQUIVALENCE   (DEVDAT,PAD(65)), (PFNDAT,PAD(77)), (TABFMT,PAD(81))
      EQUIVALENCE   (IOERCD,ASTOSD(2))
      EQUIVALENCE   (LDIX,DEVDAT(1)), (EQCODE,DEVDAT(3))
C
C                   D A T A
C
      DATA          ASTOSD(1) /1H /
      DATA          ASTMSG /6H0+++  ,8*1H /
      DATA          ERRMSG /2*1H ,    10HILLEGAL DE,10HVICE INDEX,
     $    10HINACTIVE D,10HEVICE REF ,10HFILE AINT ,10HATTACHED  ,
     $    10HILLEGAL TA,10HPE POSTION,10HILLEGAL MS,10H POSITION ,
     $    10HILLEGAL RE,10HCORD SIZE ,10HILLEGAL RE,10HAD REQUEST,
     $    10HDEVICE OVE,10HRFLOW     ,10HILLEGAL WR,10HITE REQUST,
     $    10HMISCELL. I,10H/O ERROR  ,10HO/S CANT H,10HONOR REQST /
C
C                   L O G I C
C
C=ENTRY     IOMOSD      IOMOSD      ENTRY
C=PURPOSE   PRINT OPERATION STATUS DESCRIPTORS (OSD)
C=USAGE     INTERNAL USE BY DMGASP/CDC
C
C     +++++++++++++++++++++
      ENTRY         IOM OSD
C     +++++++++++++++++++++
C
      PRINT 10,     ASTOSD(1),ASTOSD(2),ERRMSG(1,IOERCD+1),
     $              ERRMSG(2,IOERCD+1),(ASTOSD(J),J=3,14)
   10 FORMAT (16H0+++  LAST OP = A6,13H,  ERROR CODEI4/6X2A10/6X,73HDEVI
     $CE  TYPEX LCARG1 LCARG2 LOCDEV SIZREC RET/EOI STATUS DTERR/RSC NWR
     $DXF  /5X4I7,1XO6,I7,1XO3,I4,5XO2,4XO2,2XO2,I7)
      RETURN
C
C=ENTRY     IOMFET      IOMFET      ENTRY
C=PURPOSE   PRINT FILE ENVIRONMENT TABLE (FET) AREA
C=USAGE     INTERNAL USE BY DMGASP/CDC
C
C     +++++++++++++++++++++
      ENTRY         IOM FET
C     +++++++++++++++++++++
C
      LFNAME =   LFNBF(FET)
      PRINT 12,     LFNAME,(FET(J),J=1,10)
   12 FORMAT (/22H +++  F.E.T. OF FILE  ,A7/
     A   6X,7HFET+0 = O21,10X,7HFET+1 = O21 / 6X,7HFET+2 = O21,
     B  10X,7HFET+3 = O21 / 6X,7HFET+4 = O21,10X,7HFET+5 = O21/
     C   6X,7HFET+6 = O21,10X,7HFET+7 = O21 / 6X,7HFET+8 = O21,
     D  10X,7HFETEXT= O21 )
      RETURN
      ENTRY         IOMFETX
      PRINT 13,     (J,ASTPKT(J),J=1,12)
   13 FORMAT (/(6X,7HASTPKT(I2,3H)= O6,6X,7HASTPKT(I2,3H)= O6,6X,
     $    7HASTPKT(I2,3H)= O6,6X,7HASTPKT(I2,3H)= O6))
      RETURN
C
C=ENTRY     IOMTAB      IOMTAB      ENTRY
C=PURPOSE   PRINT AUXILIARY STORAGE TABLE (AST)
C=USAGE     INTERNAL USE BY DMGASP/CDC
C
C     +++++++++++++++++++++
      ENTRY         IOM TAB
C     +++++++++++++++++++++
C
      PRINT 14
   14 FORMAT (/1X,71(1H+) /2H +11X, 47HA U X I L I A R Y    S T O R A G E
     $E    T A B L E,11X,1H+/1X,71(1H+)/1X,1H+69X1H+/72H + LDI  LFN
     $ EQC TYP OPT SEC  CDLOC   NEXT  LIMIT     READ WRITTEN +)
      ASTCNT(1) =  0
      ASTCNT(2) =  0
      DO 1800  J = 1,ASTDIM
        LDIX =     J
        EQCODE =   ASTEQC(J)
        IF (EQCODE .EQ. 0)             GO TO 1800
        CALL        IOM LDIX
        PRINT TABFMT,         DEVDAT
        IF (PFNDAT(1) .NE. 0)          PRINT 16, PFNDAT
 1800   CONTINUE
   16 FORMAT (8H + (PFN= A7,5H, CY=I2,6H, ID= R8,1H),34X,1H+)
C
      PRINT 18,     ASTCNT
   18 FORMAT (2H +69X1H+ /2H + I21,17H ACTIVE DEVICES (I2,6H FULL)
     A 23X 1H+/2H + I6, 8H TP-OPS, I6,8H WRITES, I6,7H READS,
     B I8,1H/I8,12H WORDS XFD + /1X 71(1H+) /)
      RETURN
C
C=ENTRY     IOMESS      IOMESS      ENTRY
C=PURPOSE   PRINT ASTMSG (MESSAGE) ARRAY
C=USAGE     INTERNAL USE BY DMGASP/CDC AND SUBPROCESSORS
C
C     +++++++++++++++++++++
      ENTRY         IOMESSG
C     +++++++++++++++++++++
C
C
      PRINT 25,      (ASTMSG(J),J=1,7)
   25 FORMAT (A6,6A10)
      ASTMSG(1) = 6H +++
      ASTMSG(2) = 1H
      ASTMSG(3) = 1H
      ASTMSG(4) = 1H
      ASTMSG(5) = 1H
      ASTMSG(6) = 1H
      ASTMSG(7) = 1H
      RETURN
C
C=ENTRY     PADPRT      PADPRT      ENTRY
C=PURPOSE   DISPLAY CONTENTS OF CDMPAD COMMON BLOCK
C=USAGE     FOR DMGASP DEBUG PRINT ONLY
C
C     +++++++++++++++++++++
      ENTRY         PADPRT
C     +++++++++++++++++++++
C
      PRINT 32,     CMSIZ,BCSIZ,REQCM,LWAREC, (PAD(J),J=1,64)
   32 FORMAT (/6X,8HCMSIZ = O6,10H, BCSIZ = O6,10H, REQCM = O6,
     $ 11H, LWAREC = O6, 17H, PAD/SAVE AREA&  /(2X,6O21))
 5000 CONTINUE
      RETURN
      END
